VBA Code Werte Copy nach Abfragen
12.05.2018 15:59:25
Steven
Kann mir jemand den Code (läuft OK) nur vereinfachen/kürzen?
Es wird eine pdf-Datei erzeugt und gleichzeitig je nach 2 Abfragen auf unterschiedliche Bereiche Werte kopiert.
Vielen Dank schon mal für Eure Ideen...
Sub aktivesBlattToPdf()
Dim Quelle As Worksheet
Dim Ziel As Worksheet
Set Quelle = Sheets("PRÄ")
Set Ziel = Sheets("STATISTIK")
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "" & Quelle.Name & "." & Quelle.Range("D3").Value & "." & Format(Date, "YY." _
) & Range("E2") & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Ziel.Unprotect Password:="pass"
With Ziel
Quelle.Range("P8:P107").Copy
Select Case Quelle.Range("E2").Value And Quelle.Range("D3") = Tabelle15.Name
Case 1:
.Range("C4").PasteSpecial Paste:=xlValues
Case 2:
.Range("D4").PasteSpecial Paste:=xlValues
Case 3:
.Range("E4").PasteSpecial Paste:=xlValues
Case 4:
.Range("F4").PasteSpecial Paste:=xlValues
Case 5:
.Range("G4").PasteSpecial Paste:=xlValues
Case 6:
.Range("H4").PasteSpecial Paste:=xlValues
Case 7:
.Range("I4").PasteSpecial Paste:=xlValues
Case 8:
.Range("J4").PasteSpecial Paste:=xlValues
Case 9:
.Range("K4").PasteSpecial Paste:=xlValues
Case 10:
.Range("L4").PasteSpecial Paste:=xlValues
Case 11:
.Range("M4").PasteSpecial Paste:=xlValues
Case 12:
.Range("N4").PasteSpecial Paste:=xlValues
End Select
End With
With Ziel
Quelle.Range("P8:P107").Copy
Select Case Quelle.Range("E2").Value And ActiveSheet.Range("D3") = Tabelle16.Name
Case 1:
.Range("S4").PasteSpecial Paste:=xlValues
Case 2:
.Range("T4").PasteSpecial Paste:=xlValues
Case 3:
.Range("U4").PasteSpecial Paste:=xlValues
Case 4:
.Range("V4").PasteSpecial Paste:=xlValues
Case 5:
.Range("W4").PasteSpecial Paste:=xlValues
Case 6:
.Range("X4").PasteSpecial Paste:=xlValues
Case 7:
.Range("Y4").PasteSpecial Paste:=xlValues
Case 8:
.Range("Z4").PasteSpecial Paste:=xlValues
Case 9:
.Range("AA4").PasteSpecial Paste:=xlValues
Case 10:
.Range("AB4").PasteSpecial Paste:=xlValues
Case 11:
.Range("AC4").PasteSpecial Paste:=xlValues
Case 12:
.Range("AD4").PasteSpecial Paste:=xlValues
End Select
End With
With Ziel
Quelle.Range("P8:P107").Copy
Select Case Quelle.Range("E2").Value And ActiveSheet.Range("D3") = Tabelle17.Name
Case 1:
.Range("AI4").PasteSpecial Paste:=xlValues
Case 2:
.Range("AJ4").PasteSpecial Paste:=xlValues
Case 3:
.Range("AK4").PasteSpecial Paste:=xlValues
Case 4:
.Range("AL4").PasteSpecial Paste:=xlValues
Case 5:
.Range("AM4").PasteSpecial Paste:=xlValues
Case 6:
.Range("AN4").PasteSpecial Paste:=xlValues
Case 7:
.Range("AO4").PasteSpecial Paste:=xlValues
Case 8:
.Range("AP4").PasteSpecial Paste:=xlValues
Case 9:
.Range("AQ4").PasteSpecial Paste:=xlValues
Case 10:
.Range("AR4").PasteSpecial Paste:=xlValues
Case 11:
.Range("AS4").PasteSpecial Paste:=xlValues
Case 12:
.Range("AT4").PaseSpecial Paste:=xlValues
End Select
End With
Ziel.protect Password:="pass"
Worksheets("PRÄ").Select
Range("C2").Select
End Sub
Anzeige