Option
Explicit
Public
Sub
Example()
On
Error
GoTo
ErrHandler
Dim
colaFields(1
To
2)
As
VBA.Collection
Dim
rngaRow(1
To
2)
As
Excel.Range
Dim
rngaField(1
To
2)
As
Excel.Range
Dim
strStage
As
String
Dim
nRecords
As
Long
Set
colaFields(1) =
New
VBA.Collection
Set
colaFields(2) =
New
VBA.Collection
With
Worksheets(
"Tabelle2"
)
strStage =
"Initialisiere (ZIEL)"
Set
rngaRow(2) = .Range(
"A1"
, .Cells(1, .Columns.Count).
End
(xlToLeft))
For
Each
rngaField(2)
In
rngaRow(2).Cells
Call
colaFields(2).Add(Key:=Trim$(rngaField(2).Value), Item:=rngaField(2))
Next
Set
rngaRow(2) = rngaRow(2).Offset(1 + .Cells(.Rows.Count, colaFields(2).Item(
"Farbe"
).Column).
End
(xlUp).Row - rngaRow(2).Row)
End
With
With
Worksheets(
"Tabelle1"
)
strStage =
"Initialisiere (QUELLE)"
Set
rngaRow(1) = .Range(
"A1"
, .Cells(1, .Columns.Count).
End
(xlToLeft))
For
Each
rngaField(1)
In
rngaRow(1).Cells
Call
colaFields(1).Add(Key:=Trim$(rngaField(1).Value), Item:=rngaField(1))
Next
strStage =
"verarbeite Daten ..."
Set
rngaRow(1) = rngaRow(1).Offset(1)
Set
rngaField(1) = CellByField(rngaRow(1), colaFields(1),
"Hilfsspalte"
)
Dim
strCriteria
As
String
Dim
i
As
Long
strCriteria =
"rotMo1"
Do
Until
Trim$(rngaField(1).Value) =
""
If
0 = StrComp(rngaField(1).Value, strCriteria, vbTextCompare)
Then
For
i = 1
To
colaFields(2).Count
If
Exists(colaFields(1), colaFields(2).Item(i).Value)
Then
Set
rngaField(1) = CellByField(rngaRow(1), colaFields(1), colaFields(2).Item(i).Value)
Set
rngaField(2) = CellByField(rngaRow(2), colaFields(2), colaFields(2).Item(i).Value)
rngaField(2).NumberFormat = rngaField(1).NumberFormat
rngaField(2).Value = rngaField(1).Value
End
If
Next
nRecords = nRecords + 1
Set
rngaRow(2) = rngaRow(2).Offset(1)
End
If
Set
rngaRow(1) = rngaRow(1).Offset(1)
Set
rngaField(1) = CellByField(rngaRow(1), colaFields(1),
"Hilfsspalte"
)
Loop
strStage =
"verarbeite Daten ... beendet"
End
With
Call
MsgBox(
"Es wurde(n) "
& nRecords &
" Zeile(n) übertragen."
, vbInformation)
Exit
Sub
ErrHandler:
Call
MsgBox(
"Schritt:"
& vbNewLine &
" '"
& strStage &
"'"
& vbNewLine & vbNewLine & _
"Fehler ("
& Err.Number &
"): "
& vbNewLine & _
Err.Description, _
vbCritical)
End
Sub
Private
Function
CellByField(Row
As
Excel.Range, Fields
As
VBA.Collection, Field
As
String
)
As
Excel.Range
If
Exists(Fields, Field)
Then
Set
CellByField = Row.Cells(1 + Fields(Field).Column - Fields(1).Column)
End
Function
Private
Function
Exists(Collection
As
VBA.Collection, Key
As
String
)
As
Boolean
On
Error
Resume
Next
Call
Collection(Key)
Exists =
Not
CBool
(Err.Number)
End
Function