excel - 宏 Excel 从各种文件导入单张工作表

Question

我有一个宏 excel 文件，它对单元格进行了一些清理，我需要从同一个文件夹中的各种文件中导入一张表。例如，我需要与宏文件位于同一文件夹中的所有 excel 文件中的 sheet1。我有一个手动执行此操作的代码，但无论文件夹中的文件数量如何，我都需要能够通过选择文件或运行另一个宏来选择它们来自动执行此操作。

Sub Carga_Masiva()

Dim fName As String, wb As Workbook
fName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*")
Set wb = Workbooks.Open(fName)
    For Each sh In wb.Sheets
        If Application.CountA(sh.Cells) > 0 Then
            sh.Copy Before:=ThisWorkbook.Sheets(1)
            Exit For
        End If
    Next
    wb.Close False
    
End Sub

标签： excelvba

Answer 1

我会提示用户输入一个文件夹，然后遍历每个文件，除了带有你的宏的文件。

要提示输入文件夹，请使用此解决方案（在我的代码中作为可选变体）：链接

完整代码如下：

Sub Carga_Masiva()

Dim sh As Worksheet
Dim fName As String, wb As Workbook
fName = Application.GetOpenfnamename("Excel fnames (*.xl*), *.xl*")
Set wb = Workbooks.Open(fName)

For Each sh In wb.Sheets
    If Application.CountA(sh.Cells) > 0 Then
        sh.Copy Before:=ThisWorkbook.Sheets(1)
        Exit For
    End If
Next
wb.Close False
    
End Sub

Sub CopyToThisWorkbook()
    Dim wbMacro, wb As Workbook
    Set wbMacro = ThisWorkbook
    Dim sh As Worksheet
    Dim folderPath, fName, tabName As String
    
    folderPath = wbMacro.Path & Application.PathSeparator
    
    'Prompt variant
    'folderPath = GetFolder & Application.PathSeparator
    fName = Dir(PathName:=folderPath)
    
    Do
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        
        'Open all files except the one with macro
        If fName <> wbMacro.Name Then
            'Your code
            Set wb = Workbooks.Open(wbMacro.Path & "\" & fName)
            For Each sh In wb.Sheets
                If Application.CountA(sh.Cells) > 0 Then
                    tabName = sh.Name & "_" & Right(wb.Name, 10) 'Optional - rename Worksheet to be copied
                    sh.Name = tabName 'Optional
                    sh.Copy Before:=wbMacro.Sheets(1) 
                Exit For
                End If
            Next sh
            wb.Close SaveChanges:=False
        End If
       
        fName = Dir
    Loop Until fName = ""
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Function GetFolder() As String 'Optional variant
    Dim fldr As fnameDialog
    Dim sItem As String
    Set fldr = Application.fnameDialog(msofnameDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialfnameName = Application.DefaultfnamePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function