AW: Zelle.Address
15.09.2020 11:05:46
Peter
Hallo Ralf,
das ist jetzt ein bischen länger. Die Erklärungen habe ich vor Beginn der Kopier-Routine eingefügt, ich hoffe, verständlich.
Danke für die Hilfe
Peter
Sub Werte_eintragen(ByVal Inkrement As Long)
Dim Zeile As Long, Zelle As Range
Static Abstand As Long
Zeile = Range("A1")
If Zeile = 0 Then Abstand = 0
For Each Zelle In Range("B23:F47")
If Zelle.Value "" Then
Zeile = Zeile + 1
Range("F" & Zeile) = Zelle.Offset(Abstand, 0).Address
Range("G" & Zeile) = Zelle.Value
Range("A1") = Zeile + 1
End If
Next Zelle
Abstand = Abstand + Range("A2")
End Sub
Sub Lieferschein_Backup()
Dim QBL As Worksheet
Dim ZBL As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Cursor = xlWait
End With
' Alle anderen Dateien schließen
For Each wkb In Workbooks
If (wkb.Name ActiveWorkbook.Name) And (wkb.Name ThisWorkbook.Name) Then
wkb.Close savechanges:=False
End If
Next wkb
' Hole Daten aus Original-Rechnung
With Worksheets("Rechnung")
Datum = .Range("I16")
Jahr = Year(Datum)
MM = Format(Datum, "MM")
MMM = Format(Datum, "MMM")
Monat = MM & " - " & MMM
If Left(Datum, 2) 14 Then ZR = " - 15 bis Ende " & MMM
End With
' Vorbereitungen
With ThisWorkbook
Pfad = .Path & "\Backup\Lieferschein " & Jahr & "\" & MM & " - " & MMM & "\"
ART = Range("I14")
KD_Art = Range("O12")
Datei = "Kunde " & Range("F18") & "-" & KD_Art & ZR & " - " & Jahr
ZD = Pfad & Datei & ".xlsx"
End With
' Backup-Datei erstellen, Blatt
' Rechnungen formatieren, speichern
On Error Resume Next
If Dir(ZD) = "" Then
With Workbooks
.Add
With ActiveWorkbook
With .Sheets(1)
.Name = "Rechnung"
End With
.SaveAs ZD
.Close False
End With
End With
End If
Workbooks.Open ZD
On Error GoTo 0
With Workbooks(2)
.Activate
End With
Set QBL = Workbooks(1).Sheets("Rechnung") ' Quelle
Set ZBL = Workbooks(2).Sheets("Rechnung") ' Ziel
On Error Resume Next
ZBL.Unprotect
' Ab hier beginnt die Kopierroutine, die Kopfzeilen aus dem
' Rechnungsformular, allerdings habe ich das Makro
' "Werte eintragen" wohl noch nicht richtig eingebunden,
' in meiner Testdatei funktioniert es, hier noch nicht.
' Zunächst wird der Kopfbereich aus "B1:O18" kopiert, danach
' der Rechnungsbereich, wobei hier die Eintragungen angehängt,
' die Zell-Adressen entsprechend angepasst werden müssen.
' Der Lieferschein hat nur eine Seite, die Rechnung vier,
' der beschreibbare Bereich: B23:F47, B69:F103, B120:F154,
' B171:F2205
' Da der Inhalt der gesamten Lieferscheine die jeweiligen
' Schallgrenzen überschreitet, müssen entsprendend die Zell-
' adressen angepasst werden.
' Backup Kopfbereich
If Range("B1") = "" Then
With QBL
Set Bereich = .Range("B1:O18")
For Each Zelle In Bereich
If Zelle.Locked = False And Zelle.Value "" Then
Zeile = Zeile + 1 ' Zeile hochzählen
ADR = Zelle.Address
Range("B" & Zeile) = Zelle.Address ' Quell-Zell-Adresse
Range("C" & Zeile) = Zelle.Value ' Quell-Zellinhalt
ADR = Range("B" & Zeile) ' Quell-Zell-Adresse _
_
in Variable
End If
Next Zelle
End With
Range("A1") = Zeile + 1
End If
Range("A2") = QBL.Range("B22")
' Backup Rechnungsbereich
Zeile = Range("A1")
With QBL
Application.Run "Werte_eintragen", Zeile
End With
On Error GoTo 0
With ActiveWorkbook
'.SaveAs ZD
'.Close False
End With
Ende:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Cursor = xlDefault
End With
End Sub