Spalten von Tabelle zu Tabelle kopieren
03.09.2003 17:29:16
Lothar
Ich habe ja inzwischen gelernt, das "select" möglichst zu vermeiden ist.
Leider weiss ich mit meinem "Macrorecorder-VBA-Wissen" ;) nicht wie!
Situation, die montalich wiederkehrt:
Aus einer Download-Tabelle sollen 4 Spalten (nur Werte) in eine umfangreiche Tabelle (MAIN.XLS) kopiert werden. Allerdings müssen die Spalten an andere Positionen gesetzt werden. Ich habe das per Recorder aufgezeichnet und "etwas verbessert". Gefallen tut es mir aber nicht.
Zumindest habe ich es geschafft, die variablen Namen der Blätter und Tabellen zu ersetzen, da die monatlich bzw. jährlich wechseln.
Die betreffenden Dateien sind offen!
Wie kann folgender Code verbessert werden?
Vielen Dank vorab
Gruss
Lothar
Sub Download_einlesen()
Dim sFile As String
Dim sFile1 As String
Dim sPath As String
Dim sPath1 As String
Dim sPathFile As String
Dim sSheet As String
Dim sSheet1 As String
Windows("Toolbox.xls").Activate
Sheets("Programmdaten").Select
sPath = ThisWorkbook.Path & "\SAPDOWN\" 'Downloadpfad festlegen
sSheet = Range("B21").Value ' Datei-/Blattname wird hier ermittelt
sSheet1 = Range("F21").Value ' Blattname in der Haupttabelle
sFile = sSheet & ".XLS" ' Monats-Dateinamen zusammensetzen
sFile1 = "MAIN.XLS" ' In diese Tabelle müssen die Daten rein
sPathFile = sPath & sFile
Workbooks.Open Filename:=sPathFile, _
UpdateLinks:=False
Application.ScreenUpdating = False
' AB HIER MACRORECORDING (mit kleinen Verbesserungen)
Windows(sFile).Activate
Sheets(sSheet).Select
Columns("A:A").Copy
Windows(sFile1).Activate
Sheets(sSheet1).Select
Range("A1").Select
ActiveSheet.Paste
Windows(sFile).Activate
Sheets(sSheet).Select
Columns("C:C").Copy
Windows(sFile1).Activate
Sheets(sSheet1).Select
Range("C1").Select
ActiveSheet.Paste
Windows(sFile).Activate
Sheets(sSheet).Select
Columns("B:B").Copy
Windows(sFile1).Activate
Sheets(sSheet1).Select
Range("H1").Select
ActiveSheet.Paste
Windows(sFile).Activate
Sheets(sSheet).Select
Columns("E:E").Copy
Windows(sFile1).Activate
Sheets(sSheet1).Select
Range("D1").Select
ActiveSheet.Paste
Cells.Select
Application.CutCopyMode = False
With Selection.Font
.Name = "Courier New"
.Size = 9
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Columns.AutoFit
Range("A1").Select
Application.ScreenUpdating = True
End Sub