Spalten kopieren und einfügen

Hallo zusammen,
ich habe vor kurzem, von einem netten Forumsmitglied ein Makro bekommen, welches mir Spalten kopiert und in eine neue Tabelle einfügt. Diese Makro funktioniert perfekt, bezieht sich jedoch auf Tabellenblätter deren Inhalt eine "Tabelle" ist. Jetzt habe ich ein Tabellenblatt deren Inhalt keine Tabelle ist, jedoch dasselbe ausgeführt werden soll. Was muss im Code angepasst werden, dass mir das Makro auch Inhalte aus Tabellenblättern kopiert, die nicht so formatiert sind?
Option Explicit

Sub b()
Dim WbQ As Workbook, WbZ As Workbook, WsQ As Worksheet
Dim WsZ As Worksheet, tQ As ListObject, Pfad$
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Bitte einzulesende Datei wählen..."
.AllowMultiSelect = False
If .Show  -1 Then
MsgBox "Vorgang abgebrochen!", vbInformation
Exit Sub
Else: Pfad = .SelectedItems(1)
End If
End With
Application.ScreenUpdating = False
Set WbQ = Workbooks.Open(Pfad)
Set WsQ = WbQ.Worksheets(1): Set tQ = WsQ.ListObjects(1)
Set WbZ = Workbooks.Add(template:=xlWBATWorksheet)
Set WsZ = WbZ.Worksheets(1)
With tQ.DataBodyRange
.Offset(, 1).Resize(.Rows.Count, 1).Copy
WsZ.Cells(1, 2).PasteSpecial (xlPasteValuesAndNumberFormats)
.Offset(, 2).Resize(.Rows.Count, 1).Copy
WsZ.Cells(1, 3).PasteSpecial (xlPasteValuesAndNumberFormats)
.Offset(, 4).Resize(.Rows.Count, 1).Copy
WsZ.Cells(1, 12).PasteSpecial (xlPasteValuesAndNumberFormats)
End With
With WsZ
.Activate
.Cells(1, 1) = "Test1"
.Cells(1, 2) = "Test2"
End With
WbQ.Close False
ThisWorkbook.Close False
Set WbQ = Nothing: Set WbZ = Nothing: Set WsQ = Nothing
Set WsZ = Nothing: Set tQ = Nothing
End Sub

Hallo Tim,
du kannst den "normalen Range" natürlich anderst definieren.

Sub bb()
Dim WbQ As Workbook, WbZ As Workbook, WsQ As Worksheet
Dim WsZ As Worksheet, tQ As ListObject, Pfad$
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Bitte einzulesende Datei wählen..."
.AllowMultiSelect = False
If .Show  -1 Then
MsgBox "Vorgang abgebrochen!", vbInformation
Exit Sub
Else: Pfad = .SelectedItems(1)
End If
End With
Application.ScreenUpdating = False
Set WbQ = Workbooks.Open(Pfad)
Set WsQ = WbQ.Worksheets(1)
If WsQ.ListObjects.Count > 0 Then Set tQ = WsQ.ListObjects(1)
Set WbZ = Workbooks.Add(template:=xlWBATWorksheet)
Set WsZ = WbZ.Worksheets(1)
If Not tQ Is Nothing Then
With tQ.DataBodyRange
.Offset(, 1).Resize(.Rows.Count, 1).Copy
WsZ.Cells(1, 2).PasteSpecial (xlPasteValuesAndNumberFormats)
.Offset(, 2).Resize(.Rows.Count, 1).Copy
WsZ.Cells(1, 3).PasteSpecial (xlPasteValuesAndNumberFormats)
.Offset(, 4).Resize(.Rows.Count, 1).Copy
WsZ.Cells(1, 12).PasteSpecial (xlPasteValuesAndNumberFormats)
End With
Else
With WsQ.Range("A1").CurrentRegion.Columns(1)
.Offset(, 1).Resize(.Rows.Count, 1).Copy
WsZ.Cells(1, 2).PasteSpecial (xlPasteValuesAndNumberFormats)
.Offset(, 2).Resize(.Rows.Count, 1).Copy
WsZ.Cells(1, 3).PasteSpecial (xlPasteValuesAndNumberFormats)
.Offset(, 4).Resize(.Rows.Count, 1).Copy
WsZ.Cells(1, 12).PasteSpecial (xlPasteValuesAndNumberFormats)
End With
End If
With WsZ
.Activate
.Cells(1, 1) = "Test1"
.Cells(1, 2) = "Test2"
End With
WbQ.Close False
ThisWorkbook.Close False
Set WbQ = Nothing: Set WbZ = Nothing: Set WsQ = Nothing
Set WsZ = Nothing: Set tQ = Nothing
End Sub

Gruß Gerd

Forumthread: Spalten kopieren und einfügen

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial