mehrere Werte suchen Match SCHWIERIG!!!
MarkusB.
Ich habe folgendes Problem:
Ich möchte das Workbook durchsuchen lassen. Die Werte die abgeglichen werden befinden sich auf dem ersten Sheets(1) in Spalte C. In diesem Fall 001 bis z.B. 321. Wenn eine Übereinstimmung auf den folgenden Sheets vorliegt (die Werte befinden sich auch in Spalte C der jeweiligen Sheets) soll an dieser Stelle in einem festgelegten Bereich (z.B. Treffer bei Sheet(3).Range("C8") dann soll im Sheet(3).Range("E8:V8") ein Wert, in diesem Fall nach dem Betrag gesucht werden z.B: 1.234,56 Euro -->if Range("E8:V8").value 0 then ...
Dieser Wert soll dann kopiert werden und in das erste Sheets(1) in einem Festgelegten Bereich, in diesem Beispiel M8 eingefügt werden. Wichtig sind dabei die Identischen Zeilen, in diesem Beispiel 8 (i = 8)
Der Code den ich hab klappt nicht, irgendwie werden die Schleifen nicht richtig durchlaufen... bekomme immer nur einen Wert von einem Sheet kopiert und nicht alle!!! Ich glaube Case ist falsch gesetzt...
Kann mir jemand helfen?
Vielen Dank!!!
MarkusB.
Sub teste()
Dim n As Integer, i As Integer, test, wks As Worksheet
Dim rng As Object
Application.ScreenUpdating = False
With Sheets(1)
For i = 12 To .Cells(Rows.Count, 3).End(xlUp).Row
For n = 2 To Worksheets.Count
Set wks = Worksheets(n)
test = Application.Match(.Cells(i, 3), wks.Columns(3), 0)
If Not IsError(test) Then
Select Case n ' Hier soll geprüft werden welches wks
Case Is = 2
rng = wks.Range(wks.Cells(test, 5), wks.Cells(test, 19))
If Len(rng.Value) 0 Then
rng.Copy
Sheets(1).Range("M" & i).Activate
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End If
Case Is = 3
For Each rng In _
Worksheets(n).Range(Worksheets(n).Cells(test, 5), _
Worksheets(n).Cells(test, 13))
If Len(rng.Value) 0 Then
rng.Copy
Sheets(1).Activate
Range("N" & i).Activate
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End If
Next
End Select
End If
Next n
Next i
End With
Application.ScreenUpdating = True
End Sub
Anzeige