Vorweg: Welches Betriebssystem, Browser und Browserversion hast beim Erstellen des Beitrags verwendet?
Ich frage nur, weil dein Beitrag ist stilistisch 'ne Katastrophe und ich gehe nicht davon aus, dass man sowas einfach nur so runter tippt.
(Beiträge in dieser Art werden hier sehr oft nicht beantwortet. Sie werden einfach ignoriert.)
Ich verwende in diesem Beispiel die Hilfsspalte.
Das Makro ist jedoch flexibel genug - d.h. nicht viele Änderungen notwendig - dies auch ohne jene Hilfsspalte hin zu bekommen.
Vorteil von dieser Lösung ist, dass die Spalten beliebig in ihrer Reihenfolge angeordnet sein können.
Anzupassende Stellen sind im Quellcode gekennzeichnet.
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
'ZIEL
With Worksheets("Tabelle2") '<- ggf. anpassen
strStage = "Initialisiere (ZIEL)"
'Kopfzeile (Annahme: liegt in Zeile 1 und ist einzeilig)
Set rngaRow(2) = .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft))
'Zellen anhand hierer Spaltenbeschriftungen merken
For Each rngaField(2) In rngaRow(2).Cells
Call colaFields(2).Add(Key:=Trim$(rngaField(2).Value), Item:=rngaField(2))
Next
'erste freie Zeile
Set rngaRow(2) = rngaRow(2).Offset(1 + .Cells(.Rows.Count, colaFields(2).Item("Farbe").Column).End(xlUp).Row - rngaRow(2).Row)
End With
'QUELLE
With Worksheets("Tabelle1") '<- ggf. anpassen
strStage = "Initialisiere (QUELLE)"
'Kopfzeile (Annahme: liegt in Zeile 1 und ist einzeilig)
Set rngaRow(1) = .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft))
'Zellen anhand hierer Spaltenbeschriftungen merken
For Each rngaField(1) In rngaRow(1).Cells
Call colaFields(1).Add(Key:=Trim$(rngaField(1).Value), Item:=rngaField(1))
Next
strStage = "verarbeite Daten ..."
'aktuell zu verarbeitende Zeile
Set rngaRow(1) = rngaRow(1).Offset(1)
'Hilfsspalte referenzieren, aktuelle Zeile
Set rngaField(1) = CellByField(rngaRow(1), colaFields(1), "Hilfsspalte")
Dim strCriteria As String
Dim i As Long
strCriteria = "rotMo1" '<- anpassen
Do Until Trim$(rngaField(1).Value) = ""
If 0 = StrComp(rngaField(1).Value, strCriteria, vbTextCompare) Then
For i = 1 To colaFields(2).Count
'wenn Spaltenbeschriftung von Ziel in Quelle vorhanden
If Exists(colaFields(1), colaFields(2).Item(i).Value) Then
'-> Feldinhalt übertragen (1) -> (2)
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
'nächste Zeile in Ziel
Set rngaRow(2) = rngaRow(2).Offset(1)
End If
'nächste zu verarbeitende Zeile
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
'///////////////////////////////////////////
'// Hilfsfunktion von Funktion 'Example'
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
'///////////////////////////////////////////
'// Hilfsfunktion von Funktion 'Example'
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
Gruß
|