AW: Einträge kopieren und einfügen
18.12.2015 02:31:28
Christoph
Hi Mustafa,
mein Bruder ist aus Amerika zu besuch, daher erst jetzt die Lösung.
Ist relativ lang der Code. Geht mit Sicherheit einfacher. Aber er funktioniert.=)
Sub Zahlungsabgleich()
ScreenUpdating = False
Application.DisplayAlerts = False
Dim WB2 As Workbook, WS1 As Worksheet, WS2 As Worksheet, Found As Object, Adresse As String, k _
As Integer, V As String
Set WS1 = Workbooks("Material.xlsm").Sheets("Tabelle1") ' Anpassen
Dim x As String
Dim y As String
Dim Zeilenzahl As Long
Set WB2 = Workbooks("Farbtabelle.xlsx") 'Anpassen
Set WS2 = Workbooks("Farbtabelle.xlsx").Sheets("Tabelle1") ' Anpassen
WS1.Activate
Zeilenanzahl = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For k = 1 To Zeilenanzahl
If Not IsEmpty(WS1.Cells(k, 1)) Then
WS2.Activate
y = WS1.Cells(k, 1)
x = Right(y, 3)
Set Found = WS2.Columns(1).Find(What:=x, LookIn:=xlValues, LookAt:=xlWhole)
If Found Is Nothing Then
Else
Range(Found.Address).Select
Adresse = Selection.Address
Range(Adresse).Offset(0, 2).Copy
If WS1.Cells(k + 1, 5).Value = "" Then
With WS1.Range("E" & k + 1)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
Else
With WS1.Range("E" & k).End(xlDown).Offset(1, 0)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End If
Range(Adresse).Offset(0, 3).Copy
If WS1.Cells(k + 1, 6).Value = "" Then
With WS1.Range("F" & k + 1)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
Else
With WS1.Range("F" & k).End(xlDown).Offset(1, 0)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End If
Range(Adresse).Offset(0, 4).Copy
If WS1.Cells(k + 1, 7).Value = "" Then
With WS1.Range("G" & k + 1)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
Else
With WS1.Range("G" & k).End(xlDown).Offset(1, 0)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End If
Range(Adresse).Offset(0, 5).Copy
If WS1.Cells(k + 1, 8).Value = "" Then
With WS1.Range("H" & k + 1)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
Else
With WS1.Range("H" & k).End(xlDown).Offset(1, 0)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End If
Range(Adresse).Offset(0, 6).Copy
If WS1.Cells(k + 1, 9).Value = "" Then
With WS1.Range("I" & k + 1)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
Else
With WS1.Range("I" & k).End(xlDown).Offset(1, 0)
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End If
End If
End If
Next
Application.DisplayAlerts = True
ScreenUpdating = True
End Sub
Bitte um Rückmeldung, ob es funktioniert.
Gruß
Christoph