AW: Vergleich kopieren Makro
12.02.2009 11:55:00
fcs
Hallo Weis,
hier deine Prozeduren entsprechend angepasst. Hoffe das Passt, habe nur mit wenigen Daten getestet.
Gruß
Franz
Sub anKB()
Dim wks As Worksheet
'Application.SreenUpdating = False
Dim iRow As Integer, iRowL As Integer, iRowT As Integer
Dim rngBereich As Range, rngGefunden As Range, bolVorhanden As Boolean, lngSp As Long
Dim strAdresse1 As String, varSuchen
iRowL = Cells(Rows.Count, 1).End(xlUp).Row
For iRow = 1 To iRowL
Set wks = Nothing
If InStr(Cells(iRow, 2).Value, "B") Then Set wks = Worksheets("TeamB")
If InStr(Cells(iRow, 2).Value, "C") Then Set wks = Worksheets("TeamC")
If InStr(Cells(iRow, 2).Value, "D") Then Set wks = Worksheets("TeamD")
If InStr(Cells(iRow, 2).Value, "E") Then Set wks = Worksheets("TeamE")
If InStr(Cells(iRow, 2).Value, "F") Then Set wks = Worksheets("TeamF")
If InStr(Cells(iRow, 2).Value, "G") Then Set wks = Worksheets("TeamG")
'... entsprechend fortsetzen
If Not wks Is Nothing Then
If Not IsEmpty(Cells(iRow, 9)) Then 'Prüfen ob Wert in Spalte I eingetragen
iRowT = wks.Cells(Rows.Count, 1).End(xlUp).Row + 1
Set rngBereich = wks.Range(wks.Cells(6, 3), wks.Cells(iRowT, 3)) 'Bereich mit _
Nummern
varSuchen = Cells(iRow, 3).Value 'Nr der Aufgabe aus Quelle
Set rngGefunden = rngBereich.Find(what:=varSuchen, LookIn:=xlValues, lookat:= _
xlWhole)
If rngGefunden Is Nothing Then
bolVorhanden = False
Else
'1. Fundstelle merken
strAdresse1 = rngGefunden.Address
'Übereinstimmung des Datensatzes prüfen, ggf. Nummer nochmals suchen
Do
'Spaltenvergleich
bolVorhanden = False
For lngSp = 1 To 9 'Spalten A bis I vergleichen
Select Case lngSp
Case 1, 2, 3, 4, 5 '### ggf. anpassen
'Diese Spalten sollen verglichen werden, identifizieren einen Eintrag _
eindeutig
If Cells(iRow, lngSp).Value = wks.Cells(rngGefunden.Row, lngSp).Value _
Then
bolVorhanden = True
Else
bolVorhanden = False
Exit For
End If
Case Else
'diese Spalten sollen nicht mit verglichen werden
End Select
Next
If bolVorhanden = True Then Exit Do
Set rngGefunden = rngBereich.FindNext(After:=rngGefunden)
Loop Until rngGefunden.Address = strAdresse1
End If
If bolVorhanden = False Then
MsgBox "Für den Eintrag in Zeile """ & iRow & """ gibt fehlt Zeile im Zielblatt!" _
Else
Cells(iRow, 9).Copy wks.Cells(rngGefunden.Row, 9)
wks.Columns(9).AutoFit
End If
End If
End If
Next iRow
Application.CutCopyMode = False
MsgBox "Ergebnisse an den KB gesendet!"
'Application.ScreenUpdating = True
End Sub
Sub anVAB()
Dim wks As Worksheet
'Application.SreenUpdating = False
Dim iRow As Long, iRowL As Long, iRowT As Long
Dim rngBereich As Range, rngGefunden As Range, bolVorhanden As Boolean, lngSp As Long
Dim strAdresse1 As String, varSuchen
iRowL = Cells(Rows.Count, 1).End(xlUp).Row
For iRow = 6 To iRowL 'Ab Zeile 6 die Daten Vergleichen und ggf. kopieren
Set wks = Nothing
If InStr(Cells(iRow, 1).Value, "1") Then Set wks = Worksheets("VAB1")
If InStr(Cells(iRow, 1).Value, "2") Then Set wks = Worksheets("VAB2")
If InStr(Cells(iRow, 1).Value, "3") Then Set wks = Worksheets("VAB3")
If InStr(Cells(iRow, 1).Value, "4") Then Set wks = Worksheets("VAB4")
If InStr(Cells(iRow, 1).Value, "5") Then Set wks = Worksheets("VAB5")
If InStr(Cells(iRow, 1).Value, "6") Then Set wks = Worksheets("VAB6")
If InStr(Cells(iRow, 1).Value, "7") Then Set wks = Worksheets("VAB7")
If InStr(Cells(iRow, 1).Value, "8") Then Set wks = Worksheets("VAB8")
If InStr(Cells(iRow, 1).Value, "9") Then Set wks = Worksheets("VAB9")
'... entsprechend fortsetzen
If Not wks Is Nothing Then
iRowT = wks.Cells(Rows.Count, 1).End(xlUp).Row + 1
Set rngBereich = wks.Range(wks.Cells(6, 3), wks.Cells(iRowT, 3)) 'Bereich mit Nummern
varSuchen = Cells(iRow, 3).Value 'suchende Nummer aus Quelle
Set rngGefunden = rngBereich.Find(what:=varSuchen, LookIn:=xlValues, lookat:=xlWhole)
If rngGefunden Is Nothing Then
bolVorhanden = True
Else
'1. Fundstelle merken
strAdresse1 = rngGefunden.Address
'Übereinstimmung des Datensatzes prüfen, ggf. Nummer nochmals suchen
Do
'Spaltenvergleich
bolVorhanden = False
For lngSp = 1 To 9 'Spalten A bis I vergleichen
Select Case lngSp
Case 1, 2, 3, 4, 5
'Diese Spalten sollen verglichen werden, identifizieren einen Eintrag _
eindeutig
If Cells(iRow, lngSp).Value = wks.Cells(rngGefunden.Row, lngSp).Value Then
bolVorhanden = True
Else
bolVorhanden = False
Exit For
End If
Case Else
'diese Spalten sollen nicht mit verglichen werden
End Select
Next
If bolVorhanden = True Then Exit Do
Set rngGefunden = rngBereich.FindNext(After:=rngGefunden)
Loop Until rngGefunden.Address = strAdresse1
End If
If bolVorhanden = False Then
Rows(iRow).Copy wks.Rows(iRowT)
wks.Columns.AutoFit
End If
End If
Next iRow
Application.CutCopyMode = False
MsgBox "Daten an den VAB gesendet!"
'Application.ScreenUpdating = True
End Sub