使用vba将多个工作簿中的特定单元格复制到一个炒锅书中

Question

您好，请帮助我解决这个问题。

我有多个工作簿，我想将每个工作簿中的特定单元格复制到另一个工作簿中。

十分感谢

Sophannaa

Answer 1

拷贝整个代码到你选择的列表（当然了Visual Basic）。 通过运行begin（）来运行。 更改值部分“这里来了你的部分!!!”

Sub begin() 
    ThisWorkbook.Save 
    DoEvents 
    Const ROW_FIRST As Integer = 5 
    Dim intResult As Integer 
    Dim strPath As String 
    Dim objFSO As Object 
    Dim intCountRows As Integer 
    Dim sourceWB As Workbook 
    Dim targetWB As Workbook 
    Set targetWB = ThisWorkbook 
    Dim xrow As Integer 
    xrow = 5 

    Application.FileDialog(msoFileDialogFolderPicker).Title = "Please select File to load" 
    Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Choose a file" 
    intResult = Application.FileDialog(msoFileDialogFolderPicker).Show 

    For Each Item In Application.FileDialog(msoFileDialogFolderPicker).SelectedItems 
     If intResult <> 0 Then 
      Application.ScreenUpdating = False 
      Range("A:A").ClearContents 
      Range("B:B").ClearContents 
      Range("C:C").ClearContents 
      Cells(4, 1).Value = "NAME" 
      Cells(4, 2).Value = "PATH" 
      Cells(4, 3).Value = "TAIL" 
      strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) 

      Set objFSO = CreateObject("Scripting.FileSystemObject") 
      intCountRows = GetAllFiles(strPath, ROW_FIRST, objFSO) 
      Call GetAllFolders(strPath, objFSO, intCountRows) 
      Application.ScreenUpdating = True 
     End If 
    Next Item 

    Cells(1, 1).Value = Application.WorksheetFunction.CountA(Range("B:B")) - 1 
'HERE COMES YOUR PART!!! 


    Dim nextrow As Integer 
     nextrow = 2 'choose starting row where to copy the results 
     Do 
      strFile = Cells(xrow, 2).Value 
      Set sourceWB = Workbooks.Open(strFile) 
      targetWB.Sheets("desired sheet to copy to").Cells(nextrow, 1) = sourceWB.Sheets("desired sheet to copy from").Cells(2, 1) 
      'instead of cells(2,1)      up here  ^^             and here^^ choose what cells you want to copy from, edit only numbers 
      sourceWB.Save 
      sourceWB.Close 
      xrow = xrow + 1 
      nextrow = nextrow + 1 
     Loop Until ThisWorkbook.Sheets(1).Cells(xrow, 2).Value = "" 
     End Sub 

     Private Function GetAllFiles(ByVal strPath As String, ByVal intRow As Integer, ByRef objFSO As Object) As Integer 
     DoEvents 
     Dim objFolder As Object 
     Dim objFile As Object 
     Dim i As Integer 


     i = intRow - ROW_FIRST + 1 
     Set objFolder = objFSO.GetFolder(strPath) 

     For Each objFile In objFolder.Files 
      inte = InStr(1, objFile.Name, "prázdný") 
         Cells(i + ROW_FIRST - 1, 1) = objFile.Name 
         Cells(i + ROW_FIRST - 1, 2) = objFile.Path 
         Cells(i + ROW_FIRST - 1, 3) = Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, ".")) 
         i = i + 1 
     Next objFile 
     GetAllFiles = i + ROW_FIRST - 1 

     End Function 

     Private Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object, ByRef intRow As Integer) 
     DoEvents 
     Dim objFolder As Object 
     Dim objSubFolder As Object 
     Static veSpravneSlozce As Boolean 
     Set objFolder = objFSO.GetFolder(strFolder) 
     For Each objSubFolder In objFolder.subfolders 
       intRow = GetAllFiles(objSubFolder.Path, intRow, objFSO) 
       Call GetAllFolders(objSubFolder.Path, objFSO, intRow) 
     Next objSubFolder 
     End Sub 

既然是真没用到的所有值复制到一个细胞中添加nextrow转移的细胞，并写下陆续

一个值