AW: DS aus 2 Blättern vereinen
24.06.2020 23:21:06
fcs
Hallo Fraed,
hier ein entsprechendes Makro
LG
Franz
Sub Zuordnung_erstellen()
Dim wksP As Worksheet
Dim wksZ As Worksheet
Dim zeiP As Long, zeiZ As Long
Dim sTeam As String
Dim bolArchiv As Boolean
Dim StatusCalc As Long
If MsgBox("Zuordnungs-Tabelle erstellen?", vbQuestion + vbOKCancel, "ZUORDNUNG") _
= vbCancel Then Exit Sub
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
Set wksP = ActiveWorkbook.Worksheets("Plan")
Set wksZ = ActiveWorkbook.Worksheets("Zuordnung")
'in Zuordnung die Altdaten löschen
With wksZ
zeiZ = .UsedRange.Row + .UsedRange.Rows.Count - 1
If zeiZ >= 3 Then
.Range(.Rows(3), .Rows(zeiZ)).Clear
End If
End With
zeiZ = 3
With wksP
'Zeilen im Plan abarbeiten
For zeiP = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row
'Daten in Zeile im Plan kopieren nach Zuordnung
.Range(.Cells(zeiP, 1), .Cells(zeiP, 7)).Copy wksZ.Cells(zeiZ, 1)
'Name Heim-Team in Kleinbuchstaben merken
sTeam = LCase(wksP.Cells(zeiP, 6).Text)
bolArchiv = False 'Merker, ob Daten im Archiv gefunden wurden setzen
'Daten Heim-Team aus Archiv übernehmen
Call Copy_aus_Archiv(sTeam, zeiZ:=zeiZ, wksZ:=wksZ, bolArchiv:=bolArchiv)
'Name Gast-Team in Kleinbuchstaben merken
sTeam = LCase(wksP.Cells(zeiP, 7).Text)
'Daten Gast-Team aus Archiv übernehmen
Call Copy_aus_Archiv(sTeam, zeiZ:=zeiZ, wksZ:=wksZ, bolArchiv:=bolArchiv)
If bolArchiv = False Then zeiZ = zeiZ + 1 'im Archiv keine Daten zu den Teans der _
Paarung
Next zeiP
End With
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub
Sub Copy_aus_Archiv(sTeam As String, zeiZ As Long, wksZ As Worksheet, bolArchiv As Boolean)
'Team im Archiv suchen und Zeilen nach Zuordnung kopieren
Dim wksA As Worksheet
Dim zeiA As Long
Set wksA = ActiveWorkbook.Worksheets("Archiv")
With wksA
'Zeilen im Archiv abarbeiten
For zeiA = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row
'Teamnamen vergleichen
If LCase(.Cells(zeiA, 1).Text) = sTeam Then
'Daten Zeile nach zuordnung kopieren
.Range(.Cells(zeiA, 1), .Cells(zeiA, 9)).Copy wksZ.Cells(zeiZ, 8)
'Zeilenzähler für Zuordnung erhöhen
zeiZ = zeiZ + 1
'Merker auf True setzen weil Team im Archiv gefunden
bolArchiv = True
End If
Next zeiA
End With
End Sub