Hi Leute,
ich hab n Problem...
ein User drückt auf einen Knopf und dann werden aus der aktiven Excel 1-x Zeilenabschnitte in eine neue Excel kopiert.
ziel soll sein:
wenn in a28 was stehst soll excel A28:R28 kopieren
wenn in a29 was stehst soll excel A29:R29 kopieren
.
.
.
wenn in a33 was stehst soll excel A33:R33 kopieren
eingefügt soll das ganze bei der neuen tabelle in der ersten freien zeile nach A2, also A(X), und im gleichen Bereich, also A(X):R(X).
Aktuell bin ich soweit:
Alles anzeigen
Der Find und der Copy funktionieren nicht richtig...
Ich danke echt für eure Hilfe!
ich hab n Problem...
ein User drückt auf einen Knopf und dann werden aus der aktiven Excel 1-x Zeilenabschnitte in eine neue Excel kopiert.
ziel soll sein:
wenn in a28 was stehst soll excel A28:R28 kopieren
wenn in a29 was stehst soll excel A29:R29 kopieren
.
.
.
wenn in a33 was stehst soll excel A33:R33 kopieren
eingefügt soll das ganze bei der neuen tabelle in der ersten freien zeile nach A2, also A(X), und im gleichen Bereich, also A(X):R(X).
Aktuell bin ich soweit:
Quellcode
- Public Function fncCheckWorkbookOpen(ByVal strName As String) As Boolean
- 'Prüft ob Arbeitsmappe geöffnet ist
- Dim wb As Workbook
- On Error GoTo Fehler
- fncCheckWorkbookOpen = True
- Set wb = Application.Workbooks(strName)
- Fehler:
- With Err
- Select Case .Number
- Case 0 'Alles ok
- Case Else
- fncCheckWorkbookOpen = False
- End Select
- End With
- End Function
- Private Sub CommandButton1_Click()
- Dim wbQuelle As Workbook, wksQuelle As Worksheet
- Dim wbZiel As Workbook, wksZiel As Worksheet
- Dim strZiel As String, strPfadZiel As String
- Dim bolOpen As Boolean
- Dim Zeile_Z As Long, Zelle_Letzte As Range
- If MsgBox("Stunden jetzt speichern?", vbQuestion + vbOKCancel, _
- "Speichern Bemusterungsauftrag") = vbCancel Then GoTo Fehler
- On Error GoTo Fehler
- Set wbQuelle = ActiveWorkbook 'Datei "Laufkarte_zur_Auftragsabwicklung.xlsm"
- Set wksQuelle = wbQuelle.Worksheets("Intern")
- Application.ScreenUpdating = False
- strPfadZiel = "C:\Test" '### anpassen ##!!!
- 'strPfadZiel = wbQuelle.Path 'wenn beide Dateien im gleichen Verzeichnis
- strZiel = "Test.xlsx"
- If fncCheckWorkbookOpen(strZiel) Then
- Set wbZiel = Application.Workbooks(strZiel)
- bolOpen = True
- Else
- Set wbZiel = Application.Workbooks.Open(strPfadZiel & Application.PathSeparator _
- & strZiel)
- bolOpen = False
- End If
- Set wksZiel = wbZiel.Worksheets("Tabelle1")
- With wksZiel
- 'nächste Einfüge-Zeile ermitteln
- Set Zelle_Letzte = .Cells.Find(What:="*", After:=Range("A1"), _
- LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows, _
- searchdirection:=xlPrevious)
- If Zelle_Letzte Is Nothing Then
- Zeile_Z = 1
- Else
- Zeile_Z = Zelle_Letzte.Row + 1
- End If
- 'Zellinhalte übertragen - noch ohne Überprüfung - nur Werte
- wksQuelle.Range("D4:D8").Copy
- .Cells(Zeile_Z, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
- End With
- Application.CutCopyMode = False
- If bolOpen = False Then
- wbZiel.Close savechanges:=True
- End If
- Fehler:
- Application.ScreenUpdating = True
- With Err
- Select Case .Number
- Case 0 'Alles OK
- Case Else
- MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
- End Select
- End With
- Set wbZiel = Nothing: Set wksZiel = Nothing: Set Zelle_Letzte = Nothing
- Set wbQuelle = Nothing: Set wksQuelle = Nothing
- End Sub
Der Find und der Copy funktionieren nicht richtig...
Ich danke echt für eure Hilfe!