Hallo Flagg,
alles kein Problem. Hier wird die zu kopierende Zeile abgefragt. Es ist nur die Eingabe einer Zahl möglich.
Sub Uebertragen()
Dim lngZeile As Long
Dim b As Long
Dim strAntwort As String
Dim bExist As Boolean
' zu kopierende Zeile abfragen
strAntwort = InputBox("Bitte geben Sie die zu kopierende Zeile ein:", "Eingabe")
'Antwort in Zahl umwandeln
lngZeile = CLng(strAntwort)
'prüfen, ob Eingabe mindestens ab Zeile 3 erfolgt
If lngZeile < 3 Then
'falls nicht, dann Mitteilung
MsgBox "Die Zeilennummer muss mindests 3 sein!", 16, "Abbruch"
'Makro beenden
Exit Sub
End If
'prüfen, ob etwas in Spalte A steht
If Cells(lngZeile, 1) = "" Then
'falls nicht, Meldung, dass kein Blatt ausgewählt werden kann
MsgBox "In Spalte A ist kein Arbeitsblatt eingetragen! Kopieren nicht möglich", 16, "Abbruch"
'Makro beenden
Exit Sub
End If
'prüfen, ob es das in Spalte A ausgewählte Blatt in der Mappe gibt
For b = 1 To ThisWorkbook.Worksheets.Count
If Cells(lngZeile, 1).Value = Worksheets(b).Name Then
'Daten kopieren, falls das Blatt gefunden wurde
With Worksheets(b)
.Range("B2") = Cells(lngZeile, 2) 'Datum kopieren
.Range("B4") = Cells(lngZeile, 6) 'Summe x kopieren
.Range("B6") = Cells(lngZeile, 10) 'Gesamtsumme kopieren
End With
'Marker für gefundenes Blatt auf Wahr setzen
bExist = True
'Schleife für Blätter verlassen
Exit For
End If
Next b
If bExist = True Then
'Abschlussmeldung, wenn Kopieren möglich war
MsgBox "Die Daten wurden übertragen!", vbOKOnly, "Kopieren"
Else
'andernfalls Meldung, dass Blatt nicht exitiert
MsgBox "Das Arbeitsblatt " & Cells(lngZeile, 1) & " existiert in dieser Mappe nicht!" & vbLf & "Kopieren nicht möglich!", 16, "Abbruch"
End If
End Sub
Gruß
M.O.