Spalten als Quelle in Ziel importieren

Hallo zusammen,
habe mir mit dem Macrorecorder einen VBA-Code gebastelt, mit dessen Hilfe ich Werte spaltenweise in bestimmtes Tabellenblatt importieren möchte. Es muss spaltenweise geschehen, da die jeweiligen Werte der Quelldatei in andere Bereich in der Zieldatei importiert werden sollen; also die Werte aus B23:B1000 beispielsweise sollen in der Zieldatei aber D33 dargestellt werden.
Der Code soll aus der Zieldatei angestoßen werden.
Der nachfolgende Code ist abgekürzt; insgesamt sollen ca. 20 Spalten jeweils ab Zeile 23 kopiert und dann platenweise ab Zeile 33 importiert werden.
Nun mein Problem: Der nachfolgender Code stoppt zwischendurch immer wieder. Ich muss ihn immer wieder neu anstoßen, dann werden schließlich alle Werte übertragen.
Insgesamt kommt mir die Hin- und Herspringerei sowieso etwas unbeholfen vor.
Was mache ich falsch?
Gibt es eine besser Methode?
Herzlichen Dank
Dietmar aus Aachen

Option Explicit
Sub DatenImportieren()
Application.ScreenUpdating = False          ' Ausschalten der Bildschirmaktualisierung,  _
flackern weg
Windows("Quelle.xls").Activate
Application.EnableEvents = False  'weil sonst wegen Passwortabfrage gestoppt wird
Sheets("Statistik").Select
ActiveSheet.Unprotect Password:="123"  ' Passwort ausschalten, damit Makro funktioniert
Range("A25:A1000").Copy
Windows("Ziel.xls").Activate
Sheets("Statistik").Select
ActiveSheet.Unprotect Password:="123"  ' Passwort ausschalten, damit Makro funktioniert
Range("A33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Quelle.xls").Activate
Application.EnableEvents = False
Sheets("Statistik").Select
ActiveSheet.Unprotect Password:="123"  ' Passwort ausschalten, damit Makro funktioniert
Range("B25:B1000").Copy
Windows("Ziel.xls").Activate
Sheets("Statistik").Select
ActiveSheet.Unprotect Password:="123"  ' Passwort ausschalten, damit Makro funktioniert
Range("D33").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Quelle.xls").Activate
Sheets("Statistik").Select
Application.CutCopyMode = False
Windows("Ziel.xls").Activate
Sheets("Statistik").Select
ActiveSheet.Unprotect Password:="123"  ' Passwort ausschalten, damit Makro funktioniert
Range("A33").Select
Windows("Quelle.xls").Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close SaveChanges:=False
Windows("Ziel.xls").Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close SaveChanges:=True
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Option Explicit Sub KopierDat() Dim wksSrc As Worksheet 'Source Dim wksDst As Worksheet 'Destination Set wksSrc = Workbooks("Quelle.xls").Worksheets("Statistik") Set wksDst = Workbooks("Ziel.xls").Worksheets("Statistik") wksDst.Cells(33, 1).Resize(976).Value = wksSrc.Cells(25, 1).Resize(976).Value wksDst.Cells(33, 4).Resize(976).Value = wksSrc.Cells(25, 2).Resize(976).Value Set wksSrc = Nothing Set wksDst = Nothing End Sub

Option Explicit Sub KopierDat() Application.ScreenUpdating = False 'Quelldatei öffnen Dim BoAnzahl As Boolean Dim WoX As Workbook Dim StDateiname As String StDateiname = "Fall1_Quelle.xls" For Each WoX In Workbooks If WoX.Name = StDateiname Then BoAnzahl = True ' Datei gefunden Exit For End If Next WoX If BoAnzahl = False Then Workbooks.Open Filename:="C:\MLC2008\Excel_Beispieldateien\Datenü _ bertrag\" & StDateiname 'Datei öffnen 'Daten übertragen Dim wksSrc As Worksheet 'Quelle Dim wksDst As Worksheet 'Ziel Set wksSrc = Workbooks("Fall1_Quelle.xls").Worksheets("Statistik") Set wksDst = Workbooks("Fall1_Ziel.xls").Worksheets("Statistik") wksDst.Cells(33, 1).Resize(976).Value = wksSrc.Cells(22, 1).Resize(976).Value wksDst.Cells(33, 4).Resize(976).Value = wksSrc.Cells(22, 2).Resize(976).Value Set wksSrc = Nothing Set wksDst = Nothing 'Quelldatei schließen ohne Speichern Workbooks("Fall1_Quelle.xls").Activate ActiveWorkbook.Close SaveChanges:=False Application.ScreenUpdating = True MsgBox "Der Datenimport war erfolgreich, die Quelldatei wurde wieder geschlossen.", _ vbInformation, "Klasse gemacht!" End Sub

Hallo Dietmar,
deine Prüfung, ob die Datei bereits geöffnet ist, passt schon.
Dein WoX könntest du auch im weiteren Code für die Quell-Datei verwenden, aber das sind Kleinigkeiten.
Noch mal zu Resize:
Mit Resize wird lediglich der Bereich definiert.
Also ist
.Range("A25:A1000") das gleiche wie
.Cells(25, 1).Resize(976) oder
.Range(.Cells(25, 1), .Cells(1000, 1))
die Adresse als String anzugeben ist aber IMHO wenig elegant und zudem muss dieser String intern wieder übersetzt werden - ergo langsamer. Die Variante mit Resize ist kürzer als "Range(Cells(), Cells())" und benötigt nur eine Referenz auf das Worksheet (anstatt 3).
Die eigentliche Übertragen der Werte in den neuen Bereich läuft über:
Bereich1.Value = Bereich2.Value
hier sparst du dir das Kopieren und Werte einfügen.
Gruß
Christian

Sub Kopieren() Dim wbZ As Workbook, wsZ As Worksheet, wbQ As Workbook, wsQ As Worksheet Set wbQ = Workbooks("Quelle.xls") Set wsQ = wbQ.Worksheets("Quelle") Set wbZ = Workbooks("Ziel.xls") Set wsZ = wbZ.Worksheets("Statistik") wsZ.Unprotect "123" wsQ.Range("A25:A1000").Copy wsZ.Range("A33").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False wsZ.Protect "123" wbQ.cloe False wbZ.Close True End Sub

Beliebteste Forumthreads (12 Monate)

Spalten als Quelle in Ziel importieren

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread