Question

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

1）而不是设置＆＃39;设置范围1＆＃39;通过输入框，这应该始终是＆lt; B2：P65＆＃39;循环浏览文件夹中的工作表时。

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

Answer 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

Answer 2

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

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

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

2 个答案: