Code zum kopieren erweitern
02.05.2022 12:14:16
Andreas
hab einen Code, der Werte aus einer Datei in eine andere kopiert. Das funktioniert auch super, Dank der 1a Hilfe von euch :)
Den Code wollte ich jetzt aber noch erweitern, ein Stückchen hat das auch geklappt, jetzt weiß ich aber leider nicht weiter.
Der Fett markierte Teil im Code ist neu.
Die Werte werden von Spalte FR-GE aus Zeile 35 kopiert.
Möchte aber eigentlich, dass es von Zeile 35-59 kopiert, aber nur die Zeilen, in denen Spalte FR nicht leer ist.
Hoffe jemand kann helfen.
Danke vorab und einen guten Start in die Woche
Gruß Andreas
'unter Anbindung von Bibliothek "Microsoft Scripting Runtime":
'Extras, Verweise..., Hacken bei "Microsoft Scripting Runtime"
Dim FSO As New FileSystemObject
Dim DateiPfad As String
Const sPfadErledigt As String = "X:\Dateipfad\"
Const DateinamenMuster = " K xxx.xlsm"
Private Sub CommandButton1_Click()
Dim Datei As File
Dim Erg As Range
Dim wsPL As Worksheet
Const cNrAdr = "AN1" 'Adresse der Zelle, wo der Planungsnummer zu lesen ist
'1. Prüfen, dass der Pfad gültig ist
'2. Prüfen, ob Dateinummer gültig ist
'3. Prüfen ob Datei bereit existiert
'4. + 5. Vorhandensein prüfen und an der richtige Stelle kopieren
'6. Datein Speichern
'1.
If Pfad_prüfen(sPfadErledigt) Is Nothing Then
MsgBox "Verzeichnis """ & sPfadErledigt & """ nicht vorhanden oder nicht gefunden.", vbExclamation
Exit Sub
End If
'2.
Set wsPL = ThisWorkbook.Worksheets("Planung")
If Not IsNumeric(wsPL.Range(cNrAdr).Value) Then
MsgBox "Nummer """ & wsPL.Range(cNrAdr).Value & """ ist für diese Datei nicht gültig.", vbExclamation
Exit Sub
End If
'3
DateiPfad = sPfadErledigt & Replace(DateinamenMuster, "xxx", wsPL.Range(cNrAdr).Value)
Set Datei = Datei_prüfen(DateiPfad)
If Not Datei Is Nothing Then
If MsgBox("Datei """ & Datei.ShortPath & """ existiert bereits. " & vbCr & vbCr & "Überschreiben?", vbYesNo + vbQuestion) vbYes Then
Exit Sub
End If
End If
'4. + 5.
With Workbooks("Übersicht.xlsm").Worksheets("Übersicht")
Set Erg = .Range("A32:A" & .Range("A99999").End(xlUp).Row).Find(wsPL.Range("FR32").Value)
If Erg Is Nothing Then Set Erg = .Range("A99999").End(xlUp).Offset(1, 0) 'wenn kein Treffer, dann als neue Zeile am Ende
wsPL.Range("FR32:LA32").Copy
Erg.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
With Workbooks("Übersicht.xlsm").Worksheets("Aufträge")
Set Erg = .Range("A35:A" & .Range("A99999").End(xlUp).Row).Find(wsPL.Range("FR35").Value)
If Erg Is Nothing Then Set Erg = .Range("A99999").End(xlUp).Offset(1, 0) 'wenn kein Treffer, dann als neue Zeile am Ende
wsPL.Range("FR35:GE35").Copy
Erg.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
'6.
ThisWorkbook.SaveAs DateiPfad, xlOpenXMLWorkbookMacroEnabled
' ThisWorkbook.Close
End Sub
Private Sub SuchenErsetzen(Quelle As Range)
Dim Erg As Range
Set Erg = Range(Quelle.EntireColumn.Range("A32"), Quelle.Offset(-1, 0)).Find(Quelle.Value)
If Not Erg Is Nothing Then
Quelle.EntireRow.Copy Erg.EntireRow
Quelle.EntireRow.Delete
End If
End Sub
Function Pfad_prüfen(Pfad As String) As Folder
'gibt einen Folder-Objekt zurück, wenn Pfad vorhanden, sonst Nothing
On Error Resume Next
Set Pfad_prüfen = FSO.GetFolder(Pfad)
End Function
Function Datei_prüfen(Pfad As String) As File
'gibt einen File-Objekt zurück, wenn Pfad vorhanden, sonst Nothing
On Error Resume Next
Set Datei_prüfen = FSO.GetFile(Pfad)
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("AN31")) Is Nothing And Not Range("AN31") = "" Then _
Workbooks.Open "X:\Produktion\Konfektion\Schneideabteilung\Schneidepläne\Übersicht\Übersicht.xlsm"
End Sub