在Excel上为多个文件运行宏

时间：2014-03-10 18:41:58

标签： excel vba excel-vba

好的，我真的很糟糕，这就是为什么我要求帮助。

我每个月都会收到700个新文件，并且在将它们放在一起之前必须清理它们。我有一个宏，但工作总是手动完成，文件为文件。我想找到一种方法一次为每个文件运行这个宏，每个月节省大量的时间。 我知道有办法做到这一点，但我只是不知道如何。

Sub IBO()

    Rows("1:6").Select
    Selection.Delete Shift:=xlUp
    Rows("16:18").Select
    Selection.Delete Shift:=xlUp
    ActiveWindow.SmallScroll Down:=6
    Rows("31:38").Select
    Selection.Delete Shift:=xlUp
    ActiveWindow.SmallScroll Down:=12
    Rows("46:46").Select
    Selection.Delete Shift:=xlUp
    Rows("46:47").Select
    Range("R46").Activate
    Selection.Delete Shift:=xlUp
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.SmallScroll Down:=15
    Rows("62:62").Select
    Selection.Delete Shift:=xlUp
    ActiveWindow.SmallScroll Down:=-24
    Rows("34:34").Select
    Selection.Insert Shift:=xlDown
    ActiveWindow.SmallScroll Down:=-9
    Rows("19:19").Select
    Selection.Insert Shift:=xlDown
    ActiveWindow.SmallScroll Down:=-12
    Rows("4:4").Select
    Selection.Insert Shift:=xlDown
    Range("B17:C17").Select
    ActiveWindow.SmallScroll Down:=6
    Range("B17:P32").Select
    Selection.Copy
    Range("R1").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=15
    Range("B33:T48").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("AG1").Select
    ActiveSheet.Paste
    Range("A1:A3").Select
    ActiveWindow.SmallScroll Down:=33
    Range("B49:M49").Select
    ActiveWindow.SmallScroll Down:=6
    Range("B49:S64").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("AZ1").Select
    ActiveSheet.Paste
    Range("BQ1").Select
End Sub

我只想知道如何在某些内容上添加此宏，以便它可以立即在所有文件上运行

2 个答案:

答案 0 :(得分：1)

我很欣赏Ammara Digital Solutions提供的RecursiveDir功能。它与文件夹选择器很好地配对。

Public Function RecursiveDir(colFiles As Collection, _
                             strFolder As String, _
                             strFileSpec As String, _
                             bIncludeSubfolders As Boolean)

    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If

End Function

Public Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function

Sub myMacro()

    Dim strPath As String
    Dim colFiles As New Collection
    Dim varFile As Variant
    Dim wbkMyBook As Workbook

'* This is a folder picker. Left click a folder once
'* and choose select to set strPath equal to that folder.

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a folder"      '* Set the title of the folder picker window.
        .AllowMultiSelect = False       '* Do not allow multiple folders to be selected.
        .InitialFileName = "documents"  '* Set the initial location to the Windows "My Documents" folder.
        If .Show = True Then
            strPath = .SelectedItems(1) '* Set strPath equal to the selected folder.
        Else
            Exit Sub                    '* Exit the sub if you click cancel on the folder picker window.
        End If
    End With

'* Here RecursiveDir is called. It creates a collection
'* of all files (colFiles) in the path (strPath) that
'* match the filter ("*.xlsx"). The last argument (True)
'* instructs RecursiveDir to search subfolders.

    RecursiveDir colFiles, strPath, "*.xlsx", True

    For Each varFile In colFiles
        Set wbkMyBook = Workbooks.Open(varFile)

'* This is where you perform your work on each file.
'* The variable (varFile) references the current file
'* over which RecursiveDir is looping.

        Debug.Print varFile
        wbkMyBook.Sheets(1).Cells(1, 1) = "Hello."
        wbkMyBook.Close SaveChanges:=True

    Next varFile

End Sub

答案 1 :(得分：0)

基本上你需要做两件事：

  1. 获取将循环浏览文件夹中所有文件的函数
  2. 更改IBO功能，以便引用不同工作簿中的单元格

    3. 函数Example1循环遍历目录中的所有文件，并尝试将每个文件作为excel工作簿打开，然后为每个工作簿调用函数IBO：

    Sub Example1()

    dim FOLDERPATH as string
'change this to the path of your folder
    FOLDERPATH = "D:\"
  dim objwrkbook as workbook
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim i As Integer 

    ‘Create an instance of the FileSystemObject 
    Set objFSO = CreateObject(“Scripting.FileSystemObject”)
    ‘Get the folder object 
    Set objFolder = objFSO.GetFolder(FOLDERPATH)
    i = 1
    ‘loops through each file in the directory and prints their names and path 
    For Each objFile In objFolder.Files


        set objwrkbook = workbooks.add(objFile.Path)
       call IBO(objwrkbook)
        i = i + 1 
    Next objFile
End Sub

    您需要对IBO函数进行一些更改才能引用另一个工作簿中的行和单元格。在下面的示例中，我假设您已在工作簿的sheet1上获得了数据：

    Sub IBO(byref objwrkbook as Workbook)

    objwrkbook.worksheets(1).Rows("1:6").Select
    Selection.Delete Shift:=xlUp
    objwrkbook.worksheets(1).Rows("16:18").Select
    Selection.Delete Shift:=xlUp
    ActiveWindow.SmallScroll Down:=6
    objwrkbook.worksheets(1).Rows("31:38").Select
    Selection.Delete Shift:=xlUp
    ActiveWindow.SmallScroll Down:=12
    objwrkbook.worksheets(1).Rows("46:46").Select
    Selection.Delete Shift:=xlUp
    objwrkbook.worksheets(1).Rows("46:47").Select
    objwrkbook.worksheets(1).Range("R46").Activate
    Selection.Delete Shift:=xlUp
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.SmallScroll Down:=15
    objwrkbook.worksheets(1).Rows("62:62").Select
    Selection.Delete Shift:=xlUp
    ActiveWindow.SmallScroll Down:=-24
    objwrkbook.worksheets(1).Rows("34:34").Select
    Selection.Insert Shift:=xlDown
    ActiveWindow.SmallScroll Down:=-9
    objwrkbook.worksheets(1).Rows("19:19").Select
    Selection.Insert Shift:=xlDown
    ActiveWindow.SmallScroll Down:=-12
    objwrkbook.worksheets(1).Rows("4:4").Select
    Selection.Insert Shift:=xlDown
    objwrkbook.worksheets(1).Range("B17:C17").Select
    ActiveWindow.SmallScroll Down:=6
    objwrkbook.worksheets(1).Range("B17:P32").Select
    Selection.Copy
    objwrkbook.worksheets(1).Range("R1").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=15
    objwrkbook.worksheets(1).Range("B33:T48").Select
    Application.CutCopyMode = False
    Selection.Copy
    objwrkbook.worksheets(1).Range("AG1").Select
    ActiveSheet.Paste
    objwrkbook.worksheets(1).Range("A1:A3").Select
    ActiveWindow.SmallScroll Down:=33
    objwrkbook.worksheets(1).Range("B49:M49").Select
    ActiveWindow.SmallScroll Down:=6
    objwrkbook.worksheets(1).Range("B49:S64").Select
    Application.CutCopyMode = False
    Selection.Copy
    objwrkbook.worksheets(1).Range("AZ1").Select
    ActiveSheet.Paste
    objwrkbook.worksheets(1).Range("BQ1").Select
End Sub

    另外，您可以在我的博客中查看有关循环文件夹Find and List all Files in a Directory

    中文件的文章
相关问题
最新问题