AW: Excel Tabelle kopieren
22.01.2015 13:58:20
Klaus
Hallo Rene,
ich habe mich bemüht, möglichst "deine" Programmierung nicht anzufassen. Würde ich das ganze Projekt jetzt von Grund auf neu schreiben, könnte ich bestimmt die Hälfte des Codes sparen :-) Aber besser ein langer Code den du verstehst als ein kurzer Code den du nicht verstehst, oder?
Ich habe mir herausgenommen, die Formeln im Code durch Werte zu ersetzen - sonst klappt das sortieren nicht. Meine Annahme: Das sind eh Ausdrucke, die nur einmalig gebraucht werden und nicht ständig aktualisieren sollen.
Weitere Kommentare im Code, frohes testen!
Grüße,
Klaus M.vdT.
Sub NeueAufgabeErstellen()
'** Datum und Uhrzeit in einer Variable als String speichern
Dim tbzusatz As String
tbzusatz = Format(Date, "dd.mm.yy") & "_" & Format(Time, "hhmmss")
'** Namen erstellen aus Abgabe und tbzusatz um formelerstellung und übergabe zu erleichtern
Dim tbab As String
tbab = "Abgabe_" & tbzusatz
'** Namen erstellen aus Auszahlung und tbzusatz um formelerstellung und übergabe zu erleichtern
Dim tbaus As String
tbaus = "Auszahlung_" & tbzusatz
'** Tabellenblatt Abgabe Kopieren
Sheets("Abgabe").Copy Before:=Sheets(1)
With ActiveSheet
'** Tabellennamen vergeben
.Name = tbab
'** Zellen E18:E46 löschen
.Range("E18:E46").ClearContents
'** Zelle H12 Inhalt löschen (Lieferscheindatum)
.Range("H12").ClearContents
'** Bereich aus "Auszahlung" holen
.Range("E18:E46").Value = Sheets("Auszahlung").Range("G18:G46").Value
'******* Spalte E nach 0-Werten durchsuchen und diese löschen
Dim r As Range
'0-Zeilen löschen
For Each r In .Range("E18:E46")
If r.Value = 0 Then
.Range("A" & r.Row & ":G" & r.Row).ClearContents
End If
Next r
End With
'** Tabellenblatt Abgabe Kopieren
Sheets("Auszahlung").Copy Before:=Sheets(2)
With ActiveSheet
'** Tabellennamen vergeben
.Name = tbaus
'** Zellen E18:E46 löschen
.Range("E18:E46").ClearContents
'** Zellen F18:F46 löschen
.Range("F18:F46").ClearContents
'** Zelle H11 Inhalt löschen (Auszahlungsdatum)
.Range("H11").ClearContents
'** Zellen E18:E46 Füllen aus der Tabellenblatt Abgabe / OHNE LEERZEICHEN
.Range("E18:E46").FormulaR1C1 = "=IF(" & tbab & "!RC="""",""""," & tbab & "!RC)"
'** Zellen A18:A46 Füllen aus dem Tabellenblatt Abgabe
'** Wenn in dem neuen Tabellenblatt Abgabe in dem Feld A18 nichts drin steht dann schreib _
auch nix, wenn was drin steht dann hole den Inhalt
' .Range("A18:A46").FormulaR1C1 = "=WENN(" & tbab & "!RC='';'';" & tbab & "!RC)"
'SORRY - statt den Fehler in der Formel zu suchen, habe ich die Bereiche einfach per VBA ü _
bertragen. Im Prinzip hast du es richtig gemacht, nur irgendwo einen Tippfehler
.Range("A18:A46").Value = Sheets(tbab).Range("A18:A46").Value
'AUCH HIER LEERZEILEN LÖSCHEN - sonst bleibt die "Größe" der Jogginghose stehen
For Each r In .Range("E18:E46")
If r.Value = "" Then
.Range("A" & r.Row & ":G" & r.Row).ClearContents
End If
Next r
End With
'BEIDE SHEETS: Formeln gegen absolute Werte tauschen - sonst verschwimmen die Bezüge beim _
sortieren
With Sheets(tbaus)
.Range("A18:H46").Value = .Range("A18:H46").Value
End With
With Sheets(tbab)
.Range("A18:H46").Value = .Range("A18:H46").Value
End With
'BEIDE SHEETS: sortieren, um Leerzeilen weg zu bekommen.
With Sheets(tbaus)
'Zellenverbund aufheben - denn mit dem kann nicht sortiert werden!
.Range("A18:C46").UnMerge
'nach Spalte A sortieren - damit die Leerzeilen mittendrin raus fliegen
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("A18:A46"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
.Sort.SetRange .Range("A18:H46")
.Sort.Header = xlGuess
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.SortMethod = xlPinYin
.Sort.Apply
End With
With Sheets(tbab)
'Zellenverbund aufheben - denn mit dem kann nicht sortiert werden!
.Range("A18:C46").UnMerge
'nach Spalte A sortieren - damit die Leerzeilen mittendrin raus fliegen
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("A18:A46"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
.Sort.SetRange .Range("A18:H46")
.Sort.Header = xlGuess
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.SortMethod = xlPinYin
.Sort.Apply
End With
End Sub