Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

.PasteSpecial Paste:=xlFormats funktioniert nicht

.PasteSpecial Paste:=xlFormats funktioniert nicht
14.09.2017 14:30:03
Peter
Guten Tag
Ich habe 3 Workbooks (=Quelldateien), welche jeweils Worksheets mit Name "C", "D" und "E" haben.
Im Weiteren habe ich ein Workbook "Summary.xlsm" (=Zieldatei), das ebenfalls unter anderen auch die Worksheets "C", "D" und "E" hat.
Mit untenstehendem Code will ich nun die Daten der einzelnen Workbooks aus den Worksheets C, D und E in das Workbook Summary.xlsm in die jeweiligen Worksheets "C", "D" und "E" übernehmen, jedoch nur die Werte und die Formate (ohne Formeln).
Der Datenübertrag klappt. Allerdings werden nur die Daten im Worksheet "C" auch formatiert, obwohl für die Tabellen "D" und "E" auch
.PasteSpecial Paste:=xlFormats
im Code ist.
Wo ist wohl das Problem?
Gruss, Peter
Option Explicit
Sub Datenimport()
Dim c_TabN As String, d_TabN As String, e_TabN As String
Dim c_lr As String, d_lr As String, e_lr As String
Dim c_lrZiel As String, d_lrZiel As String, e_lrZiel As String
Dim c_ID_qFile As String, d_ID_qFile As String, e_ID_qFile As String
Dim c_SpNr As Long, d_SpNr As Long, e_SpNr As Long
Dim c_SpID As Long, d_SpID As Long, e_SpID As Long
Dim c_AnzID As Long, d_AnzID As Long, e_AnzID As Long
Dim c_Item2 As Long, d_item2 As Long, e_item2 As Long
Dim strVerz As String, strDatei As String, lngZ As Long, i As Long
Dim ThisWB As Workbook, QuellWB As Workbook
Dim ShTab As Worksheet, c_ZTab As Worksheet, d_ZTab As Worksheet, e_ZTab As Worksheet
Set ThisWB = ActiveWorkbook
Set c_ZTab = ThisWB.Sheets("C")
Set d_ZTab = ThisWB.Sheets("D")
Set e_ZTab = ThisWB.Sheets("E")
Set ShTab = ThisWB.Sheets("Dateien")
c_TabN = Range("_c_Tab_Q").value
c_SpNr = SpNr(Range("_c_Spa_Zd").value)
c_SpID = SpNr(Range("_c_Spa_Id").value)
c_AnzID = Range("_c_Anz_Id").value
c_Item2 = Range("_c_It_2").value
d_TabN = Range("_d_Tab_Q").value
d_SpNr = SpNr(Range("_d_Spa_Zd").value)
d_SpID = SpNr(Range("_d_Spa_Id").value)
d_AnzID = Range("_d_Anz_Id").value
d_item2 = Range("_d_It_2").value
e_TabN = Range("_e_Tab_Q").value
e_SpNr = SpNr(Range("_e_Spa_Zd").value)
e_SpID = SpNr(Range("_e_Spa_Id").value)
e_AnzID = Range("_e_Anz_Id").value
e_item2 = Range("_e_It_2").value
''Quell-Verzeichnis
strVerz = ThisWB.Path & "\" 'Backslash am Ende nicht vergessen!
ShTab.Columns(1).ClearContents  '' Liste importierter Daten löschen
'' Inhalte der Worksheets C-X löschen
c_ZTab.Cells.ClearContents: d_ZTab.Cells.ClearContents: e_ZTab.Cells.ClearContents
Application.ScreenUpdating = False
'Verzeichnis auslesen
strDatei = Dir(strVerz & "*.xlsm")
'Debug.Print strDatei
Do Until strDatei = ""
If UCase(strVerz & strDatei)  UCase(ActiveWorkbook.FullName) Then
lngZ = lngZ + 1
ShTab.Cells(lngZ, 1) = strDatei
End If
strDatei = Dir()
Loop
'Dateien nacheinander öffnen und Daten übertragen
For i = 1 To lngZ
Set QuellWB = Workbooks.Open(Filename:=strVerz & ShTab.Cells(i, 1))
c_lr = QuellWB.Worksheets(c_TabN).Cells(Rows.Count, c_SpNr).End(xlUp).Row
d_lr = QuellWB.Worksheets(d_TabN).Cells(Rows.Count, d_SpNr).End(xlUp).Row
e_lr = QuellWB.Worksheets(e_TabN).Cells(Rows.Count, e_SpNr).End(xlUp).Row
c_ID_qFile = Left(QuellWB.Name, c_AnzID)
d_ID_qFile = Left(QuellWB.Name, d_AnzID)
e_ID_qFile = Left(QuellWB.Name, e_AnzID)
''Tabelle C   '''  'Wenn Spalte nicht leer dann...
If c_lr > 0 Then
c_lrZiel = c_ZTab.Cells(c_ZTab.Rows.Count, c_SpNr).End(xlUp).Row + 1
Select Case i
Case 1
QuellWB.Worksheets(c_TabN).Range(QuellWB.Worksheets(c_TabN).Cells(1, c_SpID),  _
QuellWB.Worksheets(c_TabN).Cells(c_lr, c_SpID)) = c_ID_qFile
QuellWB.Worksheets(c_TabN).Rows("1:" & c_lr).Copy
With c_ZTab.Rows(c_lrZiel - 1)
.PasteSpecial Paste:=xlValues
.PasteSpecial Paste:=xlFormats: End With
Application.CutCopyMode = False
Case Else
QuellWB.Worksheets(c_TabN).Range(QuellWB.Worksheets(c_TabN).Cells(1, c_SpID),  _
QuellWB.Worksheets(c_TabN).Cells(c_lr, c_SpID)) = c_ID_qFile
QuellWB.Worksheets(c_TabN).Rows(c_Item2 & ":" & c_lr).Copy
With c_ZTab.Rows(c_lrZiel)
.PasteSpecial Paste:=xlValues
.PasteSpecial Paste:=xlFormats
End With
Application.CutCopyMode = False
End Select
End If
''Tabelle D
If d_lr > 0 Then
d_lrZiel = d_ZTab.Cells(d_ZTab.Rows.Count, d_SpNr).End(xlUp).Row + 1
Select Case i
Case 1
QuellWB.Worksheets(d_TabN).Range(QuellWB.Worksheets(d_TabN).Cells(1, d_SpID),  _
QuellWB.Worksheets(d_TabN).Cells(d_lr, d_SpID)) = d_ID_qFile
QuellWB.Worksheets(d_TabN).Rows("1:" & d_lr).Copy
With d_ZTab.Rows(d_lrZiel - 1)
.PasteSpecial Paste:=xlValues
.PasteSpecial Paste:=xlFormats
End With
Application.CutCopyMode = False
Case Else
QuellWB.Worksheets(d_TabN).Range(QuellWB.Worksheets(d_TabN).Cells(1, d_SpID),  _
QuellWB.Worksheets(d_TabN).Cells(d_lr, d_SpID)) = d_ID_qFile
QuellWB.Worksheets(d_TabN).Rows(d_item2 & ":" & d_lr).Copy
With d_ZTab.Rows(d_lrZiel):
.PasteSpecial Paste:=xlValues
.PasteSpecial Paste:=xlFormats
End With
Application.CutCopyMode = False
End Select
End If
''Tabelle E
If e_lr > 0 Then
e_lrZiel = e_ZTab.Cells(e_ZTab.Rows.Count, e_SpNr).End(xlUp).Row + 1
Select Case i
Case 1
QuellWB.Worksheets(e_TabN).Range(QuellWB.Worksheets(e_TabN).Cells(1, e_SpID),  _
QuellWB.Worksheets(e_TabN).Cells(e_lr, e_SpID)) = e_ID_qFile
QuellWB.Worksheets(e_TabN).Rows("1:" & e_lr).Copy
With e_ZTab.Rows(e_lrZiel - 1)
.PasteSpecial Paste:=xlValues
.PasteSpecial Paste:=xlFormats
End With
Application.CutCopyMode = False
Case Else
QuellWB.Worksheets(e_TabN).Range(QuellWB.Worksheets(e_TabN).Cells(1, e_SpID),  _
QuellWB.Worksheets(e_TabN).Cells(e_lr, e_SpID)) = e_ID_qFile
QuellWB.Worksheets(e_TabN).Rows(e_item2 & ":" & e_lr).Copy
With e_ZTab.Rows(e_lrZiel)
.PasteSpecial Paste:=xlValues
.PasteSpecial Paste:=xlFormats
End With
Application.CutCopyMode = False
End Select
End If
QuellWB.Close False  'Mappe (ohne speichern) schließen
Next i
Application.ScreenUpdating = True
End Sub

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: .PasteSpecial Paste:=xlFormats funktioniert nicht
14.09.2017 17:04:42
Peter
Hallo
Problem ist gelöst.
Anstelle vor dem Einfügen die nächste freie Zeile anzuwählen muss nur die Zelle A in der freien Zeile angewählt werden, dann klappt es.
Gruss, Peter
Anzeige

324 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige