Excel VBA代码，用于通过文件循环并将特定数据复制到一个文件 [英] Excel VBA code for Looping through files and copying specific data to one file

问题描述

我很喜欢VBA，如果有人能帮忙，我会非常感激。在下面的代码中，我只需要简单的VBA循环中的帮助。
我试图循环通过文件夹中的excel文件，并将所有文件中的源Worksheet的特定数据复制到新的工作簿（表2）。我有一个代码，占70％的工作，但我很难选择一些数据和复制它的具体格式。

  Option Explicit 
 
 Const FOLDER_PATH =C：\Temp\'REMEMBER END BACKSLASH 
 
 
 Sub ImportWorksheets（）
'========================= ================ 
'处理指定文件夹中的所有Excel文件
'================= ========================== 
 Dim sFile As String'要处理的文件
 Dim wsTarget As Worksheet 
 Dim wbSource As Workbook 
 Dim wsSource As Worksheet 
 
 Dim rowTarget As Long'输出行
 Dim FirstRow As Long，LastRow As Long 
 FirstRow = 1 
 LastRow = 5 
 Dim RowRange As Range 
 rowTarget = 2 
 
'检查文件夹是否存在
如果不是FileFolderExists（FOLDER_PATH）然后
 MsgBox指定的文件夹不存在，退出！ 
退出Sub 
结束如果
 
'重置应用程序设置错误
错误Goto errHandler 
 Application.ScreenUpdating = False 
 
'设置目标工作表
设置文件夹中的Excel文件
 sFile = Dir（FOLDER_PATH& * .xls *）
直到sFile =
 
'打开源文件并设置源工作表 -  ASSUMED WORKSHEET（1）
设置wbSource =工作簿。打开（FOLDER_PATH& sFile）
设置wsSource =表（DispForm）'编辑如果必需
 
'导入数据
用wsTarget 
对于每个rw RowRange 
如果wsSource.Cells（rw.Row，1）& wsSource.Cells（rw.Row + 1，1）=然后
退出
结束如果
 
 .Range（A& rowTarget）.Value = wsSource .Range（B1）。值
 .Range（B& rowTarget）.Value = wsSource.Cells（rw.Row，2）
 
 .Range（C & rowTarget）.Value = wsSource.Cells（rw.Row，4）
 
 .Range（D& rowTarget）.Value = sFile 
 rowTarget = rowTarget + 1 
下一个rw 
 
结束
 
 
'关闭源工作簿，增加输出行并获取下一个文件
 wbSource.Close SaveChanges： = False 
 rowTarget = rowTarget + 1 
 sFile = Dir（）
循环
 
 errHandler：
错误恢复下一步
 Application.ScreenUpdating = True 
 
'tidy up 
设置wsSource = Nothing 
设置wbSource = Nothing 
设置wsTarget = Nothin g 
 End Sub 
 
 
 
 
私有函数FileFolderExists（strPath As String）As Boolean 
如果不是Dir（strPath，vbDirectory）= vbNullString然后FileFolderExists = True 
结束函数
  

解决方案

您只能从源文件复制一行数据。所以您需要在文件循环内循环所有行，或者选择所有行的范围。

尝试以下操作：

  Dim FirstRow As Long，LastRow As Long 
 FirstRow = 9 
 LastRow = 100 
 
设置rowRange = wsSource.Range（A& FirstRow&：A& LastRow）
 
与wsTarget 
对于每个rw在rowRange 
如果wsSource.Cells（rw.Row，2）=然后
退出
结束If 
 
 .Range（A& rowTarget）.Value = wsSource。单元格（rw.Row，2）
 .Range（B& rowTarget）.Value = wsSource.Cells（rw.Row，3）
下一个rw 
结束
  

I am new to VBA and If anyone can help, I'd greatly appreciate it. I just need help in simple VBA loop in following code. I am trying to loop through excel files in a folder and copy specific data from source Worksheet in all files to a new workbook (sheet 2). I have a code which does 70% of the job but I am having difficulty in picking some data and copying it in specific format.

    Option Explicit  

    Const FOLDER_PATH = "C:\Temp\" 'REMEMBER END BACKSLASH


    Sub ImportWorksheets() 
         '=============================================
         'Process all Excel files in specified folder
         '=============================================
        Dim sFile As String 'file to process
        Dim wsTarget As Worksheet 
        Dim wbSource As Workbook 
        Dim wsSource As Worksheet 

        Dim rowTarget As Long 'output row
            Dim FirstRow As Long, LastRow As Long
    FirstRow = 1
    LastRow = 5
   Dim RowRange As Range
        rowTarget = 2 

         'check the folder exists
        If Not FileFolderExists(FOLDER_PATH) Then 
            MsgBox "Specified folder does not exist, exiting!" 
            Exit Sub 
        End If 

         'reset application settings in event of error
        On Error Goto errHandler 
        Application.ScreenUpdating = False 

         'set up the target worksheet
        Set wsTarget = Sheets("Sheet2") 

         'loop through the Excel files in the folder
        sFile = Dir(FOLDER_PATH & "*.xls*") 
        Do Until sFile = "" 

             'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
            Set wbSource = Workbooks.Open(FOLDER_PATH & sFile) 
            Set wsSource = Sheets("DispForm") 'EDIT IF NECESSARY

             'import the data
     With wsTarget
     For Each rw In RowRange
         If wsSource.Cells(rw.Row, 1) & wsSource.Cells(rw.Row + 1, 1) = "" Then
         Exit For
         End If

           .Range("A" & rowTarget).Value = wsSource.Range("B1").Value
              .Range("B" & rowTarget).Value = wsSource.Cells(rw.Row, 2)

              .Range("C" & rowTarget).Value = wsSource.Cells(rw.Row, 4)

              .Range("D" & rowTarget).Value = sFile
               rowTarget = rowTarget + 1
         Next rw

    End With


             'close the source workbook, increment the output row and get the next file
            wbSource.Close SaveChanges:=False 
            rowTarget = rowTarget + 1 
            sFile = Dir() 
        Loop 

    errHandler: 
        On Error Resume Next 
        Application.ScreenUpdating = True 

         'tidy up
        Set wsSource = Nothing 
        Set wbSource = Nothing 
        Set wsTarget = Nothing 
    End Sub 




    Private Function FileFolderExists(strPath As String) As Boolean 
        If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True 
    End Function 

解决方案

you only copy one row of data from your source file. so you need either to have a loop inside your file loop to loop all the rows, or to have a range to select all the rows.

try something like the following:

    Dim FirstRow As Long, LastRow As Long
    FirstRow = 9
    LastRow = 100

    Set rowRange = wsSource.Range("A" & FirstRow & ":A" & LastRow)

    With wsTarget
        For Each rw In rowRange
            If wsSource.Cells(rw.Row, 2) = "" Then
            Exit For
            End If

             .Range("A" & rowTarget).Value = wsSource.Cells(rw.Row, 2)
             .Range("B" & rowTarget).Value = wsSource.Cells(rw.Row, 3)
        Next rw
    End With

这篇关于Excel VBA代码，用于通过文件循环并将特定数据复制到一个文件的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！