在移调中使用PasteSpecial时出现错误1004
我写的macros有问题（见下文）。 基本上，它所做的就是对数据进行sorting，将其复制到一张新的表格中，并对数据执行一些操作，例如删除列和移动部分数据。 最后它将修改后的数据保存到.txt文件并继续循环。
当我使用F8在VBA编辑器中逐步运行代码时，它通常会顺利运行。 但是，当我从“macros”菜单运行代码时，我总是得到“错误1004”在下面的列表中提到的代码部分。 我尝试了以下来解决这个问题：
- 将代码分配给一个button，而不是从“macros”菜单运行它 – >没有成功
- 从stackoverflow上的相关post获取想法 – >没有成功
- 改写
S.Range("G1").PasteSpecial _语句为S.Range(Cells(X,Y)).PasteSpecial _– > no success
我错过了什么吗？ 还是有一个比PasteSpecial函数更容易调换数据的方法？ 我很感谢任何提示，以改善代码。
这是我的代码到目前为止（不要介意德国注释）：
Option Explicit Sub Speicherskript_txt() 'Dimensionen Dim FileName As String Dim Msg As String Dim Path As String Dim dialog As FileDialog Dim lastrow_all As Long Dim lastcol_all As Long Dim lastrow_c As Long Dim lastrow_s As Long Dim j As Integer Dim Z As Integer Dim x As String Dim S As Worksheet Dim IP As Worksheet Dim C As Worksheet 'Debug-Feature: On Error GoTo Errorcatch 'Definitionen & Auswahl des Ausgabeverzeichnisses MsgBox "Morgä!" & vbNewLine & "Ausgabeverzeichnis für TXT-Dateien wählen. Merci." Set dialog = Application.FileDialog(msoFileDialogFolderPicker) dialog.AllowMultiSelect = False If dialog.Show = -1 Then Path = dialog.SelectedItems(1) & "\" 'vom User gewähltes Ausgabeverzeichnis lastrow_all = Cells(Rows.Count, 1).End(xlUp).Row 'Definiert letzte Zeile mit Eintrag lastcol_all = Cells(1, Columns.Count).End(xlToLeft).Column 'Definiert letzte Spalte mit Eintrag Set S = Worksheets("speicherblatt") Set IP = Worksheets("inputs") Set C = Worksheets("code") 'Vorgängiges Sortieren, sodass die Datenreihenfolge immer stimmt. IP.Range(IP.Cells(1, 1), IP.Cells(lastrow_all, lastcol_all)).Sort _ Key1:=IP.Range(IP.Cells(2, 3), IP.Cells(lastrow_all, lastcol_all)), Order1:=xlAscending, _ MatchCase:=False, Orientation:=xlSortColumns, Header:=xlYes IP.Range(IP.Cells(1, 1), IP.Cells(lastrow_all, lastcol_all)).Sort _ Key1:=IP.Range(IP.Cells(2, 9), IP.Cells(lastrow_all, lastcol_all)), Order1:=xlAscending, _ MatchCase:=False, Orientation:=xlSortColumns, Header:=xlYes 'Loop-Vorbereitungen IP.Range("I1:I" & lastrow_all).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=C.Range("A1"), Unique:=True lastrow_c = C.Cells(Rows.Count, "A").End(xlUp).Row Z = lastrow_c - 1 'Pop-up Abfragen von Excel unterbinden Application.DisplayAlerts = False 'LOOOOOOP zum Schreiben der Einzeldateien For j = 1 To Z x = C.Cells(j + 1, "A").Value 'Filterkondition pro Loop 'Filtern und kopieren: IP.Cells(2, 1).CurrentRegion.AutoFilter IP.Cells(2, 1).CurrentRegion.AutoFilter 9, x 'Filtert die neunte Spalte (Spalte "I") nach dem gesuchten String x IP.Cells(2, 1).CurrentRegion.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy S.Cells(1, 1) 'Kopiert die gefilterten Zeilen und fügt sie ins Tabellenblatt "speicherblatt" ein. IP.Cells(2, 1).CurrentRegion.AutoFilter 'Kopierte Daten bearbeiten (für Ausgabe als TXT-Datei): S.Range("A:K").EntireColumn.Delete 'Löscht die unnötigen Spalten lastrow_s = S.Cells(Rows.Count, 1).End(xlUp).Row 'Definiert die letzte gefüllte Zeile vom Speicherblatt 'Transponierfunktionen in zwei Schritten (1. Schritt: Zeitspalte, 2. Schritt: HQ-Werte) S.Range(Cells(1, 1), Cells(1, 3)).Copy S.Range("G1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True S.Range("A:C").EntireColumn.Delete S.Range(Cells(1, 1), Cells(lastrow_s, 3)).Copy S.Range("E1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=True S.Range("A:C").EntireColumn.Delete 'Löscht alle unnötigen Spalten. 'Dateien schreiben: FileName = x & ".txt" 'Ausgabefile wird nach jeweiligem Hierarchiecode benannt S.SaveAs Path & FileName, xlTextWindows 'Speichert als Windows TXT S.Cells.Clear 'Löscht die übertragenen Werte nach dem Speichern wieder. Next j 'Pop-up Abfragen von Excel wieder erlauben Application.DisplayAlerts = True End If MsgBox "Finito Lavoro!" & vbNewLine & "Die Ausgabedateien befinden sich im Ordner: " & Path & vbNewLine & "Excel wird nun geschlossen." ActiveWorkbook.Saved = True Application.Quit Exit Sub Errorcatch: If Err.Number <> 0 Then Msg = "Error #" & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & "Error Line: " & Chr(13) & Err.Description MsgBox Msg End If End Sub
a） S.Range(Cells(1, 1), Cells(1, 3)).Copy中的Range.Cells属性很可能不知道它们应该属于S. 理想上更像是，
S.Range(S.Cells(1, 1), S.Cells(1, 3)).Copy S.Range("G1").PasteSpecial Paste:=xlPasteValues, Transpose:=True 'or With S .Range(.Cells(1, 1), .Cells(1, 3)).Copy .Range("G1").PasteSpecial Paste:=xlPasteValues, Transpose:=True 'alternate .Range("G1").Resize(3, 1) = _ Application.Transpose(.Range("A1").Resize(1, 3).Value) End With.
b）可以使用应用程序对象的移调function转置直接值传输。
With S .Range("E1").Resize(3, lastrow_s) = _ Application.Transpose(.Range("A1").Resize(lastrow_s, 3).Value) End With