@ > Home > Inhalt > Zellbereichskopie in VBA schnell bearbeiten Excel 97+

Gegeben sei folgendes Beispiel:

Sub ZuweisungVonGanzenBereichenOderFeldern()

 Dim arr
 Dim brr()
 arr = Range("A1:A100")
 ReDim brr(UBound(arr) - 1, 2) 
 arr(1, 1) = 1000
 For i = 0 To 2 
    For j = 0 To UBound(arr) - 1 
       brr(j, i) = i * 100 + j + arr(j + 1, 1) 
    Next 
 Next
 Range("B1:D100") = brr
End Sub

Aus dem Code (getestet mit xl2000) lässt sich ersehen:

- ein Excel-Zellbereich lässt sich einer VBA-Variant-Variablen (hier ist nicht ein Datenfeld vom Typ Variant gemeint!) zuordnen
- die Größe dieser einzelnen Variable ist gegenüber Arrays nicht gesondert eingeschränkt (getestet 60000*100 Zellen)
- Dim arr muss für ReDim sein. Ein ReDim ist nicht nötig (aber möglich).
- die umgekehrte Zuweisung von arr zu einem Range funktioniert ebenso (im Beispiel brr statt arr)
- genauso kann man brr einem Range zuweisen, auch wenn brr() als Datenfeld dimensioniert/redimensioniert wurde
- während die Indizes (für Zeile und Spalte) von arr jeweils mit 1 beginnen (in Anlehnung an den Spezialfall Excel-Zellbereich),
   beginnen die von brr() mit 0 - ohne Verwendung von Option Base 1
- bei der Zuweisung von brr auf einen Zellbereich wird der Index =0 automatisch als am Ziel =1 verwendet
- arr ist zweidimensional, brr() wie gewohnt n-dimensional
- bei arr = Range(...) gibt es keine Zuviel- oder Zuwenig-Zuweisung, da arr als Variant-Variable die übergebenen Daten verwaltet
- bei Range(...) = arr wird überzähligen Zellen #NV zugewiesen; ein zu kleiner Range(...) schneidet überzählige arr-Einträge ab
- Operationen wie arr = Range(...) * 2 während der Zuweisungen von Arrays zu und von Einzel-Variablen sind nicht möglich
- dies gilt alles auch für Sub und Function mit Range-Argument-Übergabe (wie in 0036.htm)

Ein Anwendungsbeispiel: A:D soll wie in F:I nebeneinandergestellt werden:

        A     B     C     D     E     F     G     H     I 
  1  Key1  Wert1 Key2  Wert2                              
  2  A-100    1  A-101    2        A-100    1             
  3  A-102    2  A-103    3                    A-101    2 
  4  A-103    3  A-104    4        A-102    2             
  5  A-105    4  A-107    4        A-103    3  A-103    3 
  6  A-106    5  A-108    5                    A-104    4 
  7  A-107    6  A-109    6        A-105    4             
  8  A-108    8  A-110    7        A-106    5             
  9  A-110    9  A-111    6        A-107    6  A-107    4 
 10  A-111   10  A-112    6        A-108    8  A-108    5 
 11  A-114   11  A-113    5                    A-109    6 
 12  A-115   12  A-114    6        A-110    9  A-110    7 

Hier der Code, der bei einem "PC Phenom 2,3 Ghz Quadcore - Excel 2000" und je 32.000 Einträgen in A:B und C:D ca. 0,3 Sekunden benötigt:

Option Base 1

Sub Gegenueberstellung()

Dim b(65536, 4)

'unique random data, ascending in each A, B, C, D.
'A and C later being compared
   Range("A1").Clear
   Range("A2:A32000,C2:D32000") = "=ROUND(RAND()*3,)+1+R[-1]C"
   Range("B2:B32000,D2:D32000") = "=R[-1]C+1"
   Range("A:D") = Range("A:D").Value
        
Start = Timer()
        
a = Range("A:D")
i = 2: j = 2: k = 1: l = 1

Do Until k > 65000 Or l > 65000

  If a(i, 1) = a(j, 3) Then
     k = IIf(k > l, k, l) + 1
     l = k
     For m = 1 To 2
        b(k, m) = a(i, m)
        b(l, m + 2) = a(j, m + 2)
     Next m
     i = i + 1
     j = j + 1
  ElseIf a(i, 1) < a(j, 3) Then
     k = k + 1
     l = l + 1
     For m = 1 To 2
        b(k, m) = a(i, m)
     Next m
     i = i + 1
  ElseIf a(i, 1) > a(j, 3) Then
     k = k + 1
     l = l + 1
     For m = 3 To 4
        b(l, m) = a(j, m)
     Next m
     j = j + 1
  End If

Loop

Range("F:I") = b
Range("A1") = "Time elapsed: " & (Timer() - Start)

End Sub