VBA 导入和转置多个工作表数据答案

【问题标题】：VBA to import and transpose multiple sheets dataVBA 导入和转置多个工作表数据
【发布时间】：2016-06-13 22:32:34
【问题描述】：

我一直在编写以下代码，但我希望进一步编辑：

1) 循环浏览文件夹中的工作表时，不应通过输入框设置“Set Range1”，而应始终为“B2:P65”的单元格范围。

2) 粘贴数据时，我希望从工作簿中“数据库”选项卡的 B 列开始填充数据，然后是文件夹循环中的其余工作簿的 C、D、E 等。

Sub LoopFileUpload_base()
Dim wb As Workbook
Dim myPath As String
Dim myfile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer

  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

  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
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

  myExtension = "*.xlsx"

  myfile = Dir(myPath & myExtension)

  Do While myfile <> ""
      Set wb = Workbooks.Open(fileName:=myPath & myfile)

'CHANGE CODE BELOW HERE

xTitleId = "Range"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0

For Each Rng In Range1.Rows
    Rng.Copy
    Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    rowIndex = rowIndex + Rng.Columns.Count
Next

'CHANGE CODE ABOVE HERE

      wb.Close SaveChanges:=True
      myfile = Dir
  Loop

  MsgBox "Task Complete!"

ResetSettings:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

【问题讨论】：

标签： vba excel transpose

【解决方案1】：

考虑以下宏，您可以在其中循环遍历文件夹中的 .xlsx 工作簿，并逐行迭代地将指定范围内的单元格复制到当前工作表。然后，在每个工作簿移动到下一列之后：

Sub TransposeWorkbooks()
    Dim strfile As String
    Dim sourcewb As Workbook
    Dim i As Integer, j As Integer
    Dim cell As Range

    strfile = Dir("C:\Path\To\Workbooks\*.xlsx")

    ThisWorkbook.Sheets("Database").Activate
    ThisWorkbook.Sheets("Database").Range("A2").Activate

    Do While Len(strfile) > 0

        ' OPEN SOURCE WORKBOOK
        Set sourcewb = Workbooks.Open("C:\Path\To\Workbooks\" & strfile)

        ThisWorkbook.Activate
        ActiveCell.Offset(0, 1).Activate                    ' MOVE TO NEXT COLUMN
        ActiveCell = strfile

        ' ITERATE THROUGH EACH CELL ACROSS RANGE
        j = 1
        For Each cell In sourcewb.Sheets(1).Range("B2:P65")
            ActiveCell.Offset(j, 0).Value = cell.Value      ' MOVE TO NEXT ROW
            j = j + 1
        Next cell

        ' CLOSE WORKBOOK
        sourcewb.Close False
        strfile = Dir
    Loop

End Sub

【讨论】：

非常感谢上述内容，这非常有效。但是有一个小的变化，我需要将文件循环到与存储工作簿的文件夹不同的文件夹中 - 当我更改 'strfile = Dir("' 中的文件路径时，这不起作用。跨度>
这是指向当前工作簿文件夹的Set sourcewb 行，而不是strfile = Dir 行中定义的'C:\Path\To\Workbooks'。请参阅上面的编辑。请根据需要进行调整。如果有帮助，请接受答案并确认解决方案。

【解决方案2】：

听起来你的任务已经解决了。为了将来参考，请从下面的链接尝试加载项。我想你会发现这个工具有很多用途。

http://www.rondebruin.nl/win/addins/rdbmerge.htm

【讨论】：