Question

我写的宏有问题（见下文）。基本上，它的作用是对数据进行排序，将其复制到新工作表并对数据执行一些操作，例如删除列和转置部分数据。最后，它将修改后的数据保存到.txt文件并继续循环。

当我使用F8在VBA编辑器中逐步运行代码时，通常情况良好。但是，当我运行＆＃34;宏＆＃34;菜单，我总是得到＆＃34;错误1004＆＃34;在下面列表中提到的代码部分。我尝试了以下方法来解决问题：

将代码分配给按钮，而不是从＆＃34;宏＆＃34;中运行代码。菜单 - ＆gt;没有成功
从stackoverflow上的相关帖子中获取想法 - ＆gt;没有成功
将S.Range("G1").PasteSpecial _语句改为S.Range(Cells(X,Y)).PasteSpecial _ - ＆gt;没有成功

我错过了什么吗？或者，与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

Answer 1

a）S.Range(Cells(1, 1), Cells(1, 3)).Copy中的Range.Cells property很可能不知道它们属于 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）可以使用应用程序对象的Transpose function转换直接值转移。

With S
    .Range("E1").Resize(3, lastrow_s) = _
        Application.Transpose(.Range("A1").Resize(lastrow_s, 3).Value)
End With

将PasteSpecial与Transpose

1 个答案: