Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Odejmowanie zakresów

Artik · Wysłany: 09-04-2024, 11:02 **Odejmowanie zakresów**

Niedawno natknąłem się na rewelacyjne rozwiązanie problemu odejmowania zakresów. Na naszym forum ostały się (prawdopodobnie) dwa przykłady z zastosowaniem pętli. Na małych zakresach być może wystarczające. Natomiast na dużych... ech, szkoda gadać.

1 rozwiązanie, gdy z dużego zakresu (cały arkusz) odejmujemy stosunkowo mały zakres. Autorstwa Dicka Kusleiki

Kod:

Option Explicit
'https://www.mrexcel.com/board/threads/subtracting-ranges.1255737/post-6166124
'by Dick Kusleika
Private mrBuild As Range

Sub Test2()

Dim A As Range, B As Range, R As Range
Dim sngStartTimer As Single

sngStartTimer = Timer

With ActiveSheet
Set A = .Cells
Set B = .Range(.Cells(2, 2), .Cells(500, 500))
End With
Set R = SubtractRanges2(A, B)
If Not R Is Nothing Then R.Select

MsgBox Timer - sngStartTimer

End Sub

Public Function SubtractRanges2(rFirst As Range, rSecond As Range) As Range

Dim rInter As Range
Dim rReturn As Range
Dim rArea As Range

Set rInter = Intersect(rFirst, rSecond)
Set mrBuild = Nothing

If rInter Is Nothing Then 'No overlap
Set rReturn = rFirst
ElseIf rInter.Address = rFirst.Address Then 'total overlap
Set rReturn = Nothing
Else 'partial overlap
For Each rArea In rFirst.Areas
BuildRange rArea, rInter
Next rArea
Set rReturn = mrBuild
End If

Set SubtractRanges2 = rReturn

End Function

Sub BuildRange(rArea As Range, rInter As Range)

Dim rLeft As Range, rRight As Range
Dim rTop As Range, rBottom As Range

If Intersect(rArea, rInter) Is Nothing Then 'no overlap
If mrBuild Is Nothing Then
Set mrBuild = rArea
Else
Set mrBuild = Union(mrBuild, rArea)
End If
Else 'some overlap
If rArea.Columns.Count = 1 Then 'we've exhausted columns, so split on rows
If rArea.Rows.Count > 1 Then 'if one cell left, don't do anything
Set rTop = rArea.Resize(rArea.Rows.Count \ 2) 'split the range top to bottom
Set rBottom = rArea.Resize(rArea.Rows.Count - rTop.Rows.Count).Offset(rTop.Rows.Count)
BuildRange rTop, rInter 'rerun it
BuildRange rBottom, rInter
End If
Else
Set rLeft = rArea.Resize(, rArea.Columns.Count \ 2) 'split the range left to right
Set rRight = rArea.Resize(, rArea.Columns.Count - rLeft.Columns.Count).Offset(, rLeft.Columns.Count)
BuildRange rLeft, rInter 'rerun it
BuildRange rRight, rInter
End If
End If

End Sub

2 rozwiązanie. I to jest rewelacja. Autorstwa Jaafara Tribaka

Kod:

Option Explicit
'https://www.mrexcel.com/board/threads/subtracting-ranges.1255737/post-6166309
'by Jaafar Tribak
Sub Test()

Dim A As Range, B As Range, R As Range
Dim sngStartTimer As Single

sngStartTimer = Timer
With Arkusz1
Set A = .Cells
Set B = .Range(.Cells(2, 2), .Cells(.Rows.Count - 1, .Columns.Count - 1))
Set R = SubtractRanges(A, B)
If Not ActiveSheet Is Arkusz1 Then
.Activate
End If
End With
If Not R Is Nothing Then R.Select
MsgBox Timer - sngStartTimer

End Sub

Function SubtractRanges(ByVal MinuEndRange As Range, ByVal SubtrahEndRange As Range) As Range

Dim oTmpWb As Workbook, oTmpSh As Worksheet
Dim oParentSheet As Worksheet
Dim sAddr As String
Dim nSINW As Long

With Application
nSINW = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1&
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With

On Error Resume Next
If ThisWorkbook.ProtectStructure = False Then
Set oTmpWb = ThisWorkbook
Set oTmpSh = oTmpWb.Sheets.Add
Else
Set oTmpWb = CreateObject("Excel.Sheet")
Set oTmpSh = oTmpWb.Sheets(1)
End If
Set oParentSheet = MinuEndRange.Worksheet
Set MinuEndRange = oTmpSh.Range(MinuEndRange.Address)
Set SubtrahEndRange = oTmpSh.Range(SubtrahEndRange.Address)
With MinuEndRange
.Validation.Add Type:=xlValidateCustom, Formula1:="=TRUE"
SubtrahEndRange.Validation.Delete
Set SubtractRanges = .SpecialCells(xlCellTypeAllValidation)
End With
sAddr = SubtractRanges.Address
If oTmpSh.Parent Is ThisWorkbook Then
oTmpSh.Delete
End If
If Err.Number = 0& Then
Set SubtractRanges = oParentSheet.Range(sAddr)
Else
Set SubtractRanges = Nothing
End If
Application.EnableEvents = True
Application.SheetsInNewWorkbook = nSINW

End Function

Co prawda, wykorzystuje arkusz tymczasowy, co może powodować lekkie opóźnienie, ale w porównaniu z innymi rozwiązaniami działa "na pstryk".

Artik

master_mix · Wysłany: 14-04-2024, 18:42

Moja propozycja, bez kopiowania, więc nieco szybsza

Odejmowanie zakresów.xlsm

Pobierz Plik ściągnięto 76 raz(y) 31.61 KB

Marecki · Wysłany: 17-04-2024, 20:35

I co Ty Artik, wyjeżdżasz tu z jakimś 'by Dick Kusleika czy 'by Jaafar Tribak (oczywiście niczego im nie ujmując), ale nasz master to MASTER. :lol:

master_mix · Wysłany: 18-04-2024, 14:20

czasami proste rozwiązania bywają dobre ;-)

oczywiście powyższą konstrukcję można rozbudowywać.
Np w klasie budowniczego: "Unia" wystarczy zagnieździć dodatkową pętlę
i można dla argumentów podać 2 nieciągłe zakresy, czyli od nieciągłego odjąć nieciągły

Odejmowanie 2 nieciągłych zakresów.xlsm

Pobierz Plik ściągnięto 59 raz(y) 33.61 KB