Question

我有一个包含近1,000个.csv文件的文件夹。我想从每个文件中获取第二列并将它们转置粘贴到新的Excel工作簿中，以便数据在一行中。以下是我到目前为止：

Sub OpenFiles2()

  Dim MyFolder As String
  Dim MyFile As String

  'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

  With FldrPicker
    .Title = "Select A Target Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    myPath = .SelectedItems(1) & "\"
  End With

  'In Case of Cancel
  NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

  ResetSettings:
  'Reset Macro Optimization Settings
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True

  Do While myPath <> ""
    Range(Range("B1"), Range("B1").End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWorkbook.Close True
    Windows("Compiled.xlsm").Activate
    Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1,0).PasteSpecial Transpose:=True

    MyFile = Dir
  Loop
End Sub

由于某种原因，我一直收到Paste Special命令的错误。我也尝试用以下代码替换它：

ActiveSheet.PasteSpecial Transpose:=True

和

Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=      False, Transpose:=True

仍有错误。请帮忙。谢谢。

Answer 1

我会避免使用select并处理这些值。此代码将原始值存储在变量中，然后您可以通过使用VBA中的Application.Transpose来关闭活动工作簿并使用该变量中的数据。

使用以下代码替换Do Loop。

Do While myPath <> ""
    lastrow = Cells(Rows.Count, 2).End(xlUp).Row
    x = Range("B1:B" & lastrow).Value
    ActiveWorkbook.Close True
    With Worksheets("Sheet1")
        Range("A" & .Cells(.Rows.Count, 1).End(xlUp).Row + 1). _
        Resize(, lastrow).Value = Application.Transpose(x)
    End With
    MyFile = Dir
Loop

如何使用包含多个文件的文件夹将列和转置粘贴复制到新工作簿中？

1 个答案: