VBA导入和转置多张数据

Question

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

1) 不要通过输入框设置 'Set Range1'，当循环浏览文件夹中的工作表时，这应该始终是 'B2:P65' 的单元格范围。

2) 粘贴数据时，我希望从工作簿中 'Database' 选项卡的 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

Answer 1

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

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

Answer 2

听起来你的任务已经解决了。为了将来参考，请尝试下面 link 中的插件。我想你会发现这个工具有很多用途。

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

VBA导入和转置多张数据

VBA to import and transpose multiple sheets data

excel

vba

transpose