Question

我正在做一个办公室项目，我需要创建一个宏。

我有一个包含30个子文件夹的文件夹，每个子文件夹都以我们的分支命名。例如，芝加哥分公司，纽约分公司等。每个子文件夹包含许多工作簿，每个工作簿都有许多工作表，其中包含大量数据。

我制作了一个宏来从工作表中提取一些名为＆＃34;菜单＆＃34;和工作表中的一个单元格称为＆＃34;得分＆＃34;并将其粘贴到新工作簿中。

我在网上进行了研究并制作了两个单独的宏来从两个单独的工作表中获取数据。但它只有在我选择子文件夹中的所有文件时才有效。

我还发现了一些代码来访问子文件夹中的文件夹，但是我无法用我当前的代码编译它。另外，我无法加入我制作的两个宏，所以它只需要一个按钮而不是两个按钮。

现在，我需要一个宏，它会要求我选择一个文件夹，然后单独转到子文件夹中的子文件夹和文件夹，并将数据合并到一个新的工作簿中，但是在基于子文件夹的单独工作表中（分支命名为1），而不是子文件夹中的文件夹。

从子文件夹内的文件夹中的工作簿中提取的数据需要位于以子文件夹命名的工作表中。）我们的想法是必须按一下命令按钮，以便立即从该文件夹和子文件夹中提取所有数据因为太忙了，不能使用我的代码30次30个子文件夹来获取30个分支的数据。

＆＃34;宏用于从每个工作簿的工作表菜单中提取数据＆＃34;

mmap

＆＃34;宏用于从每个工作簿的工作表SCORE中提取数据＆＃34;

Private Sub CommandButton1_Click()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String
Dim aCell As Range, bCell As Range
Dim lastRow As Long, i As Long
Dim ExitLoop As Boolean

ShName = "Menu"  '<---- Change
Set Rng = Range("B9:b13")    '<---- Change

'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
                                          MultiSelect:=True)

If IsArray(FileNameXls) = False Then
    'do nothing
Else
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    'Add a new workbook with one sheet for the Summary
    Set SummWks = Sheets("Sheet1")
    'The links to the first workbook will start in row 2
    RwNum = 2

    For FNum = LBound(FileNameXls) To UBound(FileNameXls)
        ColNum = 1
        RwNum = RwNum + 1
        FinalSlash = InStrRev(FileNameXls(FNum), "\")
        JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
        JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)

        'build the formula string
        JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
        PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

        On Error Resume Next
        SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
        If Err.Number <> 0 Then
            'If the sheet not exist in the workbook the row color will be Yellow.
            SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
                    .Interior.Color = vbYellow
        Else
            For Each myCell In Rng.Cells
                ColNum = ColNum + 1
                SummWks.Cells(RwNum, ColNum).Formula = _
                "=" & PathStr & myCell.Address
            Next myCell
        End If
        On Error GoTo 0
    Next FNum

    ' Use AutoFit to set the column width in the new workbook
    SummWks.UsedRange.Columns.AutoFit
    Range("b2").Select
ActiveCell.FormulaR1C1 = "Client Name"
Range("C2").Select
ActiveCell.FormulaR1C1 = "Occupation"
Range("D2").Select
ActiveCell.FormulaR1C1 = "Date"
Range("E2").Select
ActiveCell.FormulaR1C1 = "Insured Location"
Range("F2").Select
ActiveCell.FormulaR1C1 = "Serveyed by"

Range("B1").Select
ActiveCell.FormulaR1C1 = "=""Property Risk Scores Updated as at """

Rows("1:1").RowHeight = 27.75
Range("B1").Select
With Selection.Font
    .Name = "Calibri"
    .Size = 16
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontMinor
End With
Range("C1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("c1").Select
With Selection.Font
    .Name = "Calibri"
    .Size = 16
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontMinor
End With

Range("b2:f2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Font.Bold = True
Application.ScreenUpdating = True

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End If
For Each SummWks In ThisWorkbook.Sheets
    Set aCell = SummWks.Rows(2).Find(what:="Date", LookIn:=xlValues, _
    lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    ExitLoop = False

    If Not aCell Is Nothing Then
        Set bCell = aCell

        SummWks.Columns(aCell.Column).NumberFormat = "dd/mm/yyyy;@"

        lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
        SummWks.Rows.Count).End(xlUp).Row

        For i = 2 To lastRow
            With SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i)
                .FormulaR1C1 = .Value
            End With
        Next i

        SummWks.Columns(aCell.Column).AutoFit

        Do While ExitLoop = False
            Set aCell = SummWks.Rows(2).FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do

                SummWks.Columns(aCell.Column).NumberFormat = "dd/mm/yyyy;@"

                lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
                SummWks.Rows.Count).End(xlUp).Row

                For i = 2 To lastRow
                    SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).FormulaR1C1 = _
                    SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).Value
                Next i
            Else
                ExitLoop = True
            End If
        Loop
    End If
Next

End Sub

Answer 1

好的，我想我理解这个要求。尝试沿着这些方向做点什么？

Dim oSheet 
Dim oFso : Set oFso = CreateObject("Scripting.FileSystemObject")
Dim oFolder : Set oFolder = oFso.GetFolder("Path to Desktop Branch Data folder in here")
Dim oSubFolder, oBranchWorkbook, oWorksheet, iSheet
iSheet = 1
For Each oSubFolder in oFolder.SubFolders
    Debug.Print "Looking inside " & oSubFolder.Name
    ' Set the sheet to copy to (1 on the first, 2 on the second etc)
    ' this would be better if the sheets were named for each branch folder
    ' as then instead of iSheet you could use oSubFolder.Name and it wouldn't matter if things were out of order for some reason...
    Set oSheet = ThisWorkbook.Worksheets(iSheet) 
    For Each oFile in oSubFolder.Files
        If Right(oFile.Name,3) = "xls" or Right(oFile.Name, 4) = "xlsx" Then
            Set oBranchWorkbook = Workbooks.Open(oSubFolder.Path & oFile.Name)
            ' Now you have the Info.xls from whichever branch folder we are in open
            Set oWorksheet = oBranchWorkbook.Worksheets("Menu")
            ' Extract whatever you need from Menu to the current workbook, e.g.
            oSheet.Range("A1").Value = oWorksheet.Range("B1").Value

            ' Once you complete the Menu extract, change oWorksheet to point at Score
            Set oWorksheet = oBranchWorkbook.Worksheets("Score")
            ' Extract whatever you need from Score to the current workbook, e.g.
            oSheet.Range("A1").Value = oWorksheet.Range("B1").Value

            'Once you have completed all the extracts you need, close the branch workbook
            oBranchWorkbook.Close
       End If
    Next
    iSheet = iSheet + 1 ' increment sheet counter
Next ' Move onto next subfolder and repeat the process...

Answer 2

@dave我发布这个作为答案，因为它作为评论发布太长了。你能否检查哪些部件需要更正？非常感谢！

此外，我还需要一个将分支数据放在不同工作表中的代码。例如，在工作表1中将包含我从X分支文件夹中提取的所有信息，工作表2将包含我从Y分支文件夹中提取的所有信息。

 Private Sub CommandButton1_Click()
 Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String
Dim aCell As Range, bCell As Range
Dim lastRow As Long, i As Long
Dim ExitLoop As Boolean

Dim oSheet: Set oSheet = ThisWorkbook.Worksheets("Sheet to copy to in here")
Dim oFso: Set oFso = CreateObject("Scripting.FileSystemObject")
Dim oFolder: Set oFolder = oFso.GetFolder("Path to Desktop Branch Data folder in here")
Dim oSubFolder, oBranchWorkbook, oWorksheet
For Each oSubFolder In oFolder.SubFolders
Debug.Print "Looking inside " & oSubFolder.Name
Set oBranchWorkbook = Workbooks.Open(oSubFolder.Path & "*.xl*")
' Now you have the Info.xls from whichever branch folder we are in open
Set oWorksheet = oBranchWorkbook.Worksheets("Menu")
' Extract whatever you need from Menu to the current workbook, e.g.
oSheet.Range("B2").Value = oWorksheet.Range("B9:b13").Value

' Once you complete the Menu extract, change oWorksheet to point at Score
Set oWorksheet = oBranchWorkbook.Worksheets("Score")
' Extract whatever you need from Score to the current workbook, e.g.
oSheet.Range("G2").Value = oWorksheet.Range("F65").Value

'Once you have completed all the extracts you need, close the branch workbook
oBranchWorkbook.Close
Next ' Move onto next subfolder and repeat the process...


If IsArray(FileNameXls) = False Then
    'do nothing
Else
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    'Add a new workbook with one sheet for the Summary
    Set SummWks = Sheets("Sheet1")
    'The links to the first workbook will start in row 2
    RwNum = 2

    For FNum = LBound(FileNameXls) To UBound(FileNameXls)
        ColNum = 1
        RwNum = RwNum + 1
        FinalSlash = InStrRev(FileNameXls(FNum), "\")
        JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
        JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)


        'build the formula string
        JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
        PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"

        On Error Resume Next
        SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
        If Err.Number <> 0 Then
            'If the sheet not exist in the workbook the row color will be Yellow.
            SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
                    .Interior.Color = vbYellow
        Else
            For Each myCell In Rng.Cells
                ColNum = ColNum + 1
                SummWks.Cells(RwNum, ColNum).Formula = _
                "=" & PathStr & myCell.Address
            Next myCell
        End If
        On Error GoTo 0
    Next FNum

    ' Use AutoFit to set the column width in the new workbook
    SummWks.UsedRange.Columns.AutoFit
    Range("b2").Select
ActiveCell.FormulaR1C1 = "Client Name"
Range("C2").Select
ActiveCell.FormulaR1C1 = "Occupation"
Range("D2").Select
ActiveCell.FormulaR1C1 = "Date"
Range("E2").Select
ActiveCell.FormulaR1C1 = "Insured Location"
Range("F2").Select
ActiveCell.FormulaR1C1 = "Serveyed by"
 Range("g2").Select
ActiveCell.FormulaR1C1 = "Score"

 Range("B1").Select
ActiveCell.FormulaR1C1 = "=""Property Risk Scores Updated as at """

Rows("1:1").RowHeight = 27.75
Range("B1").Select
With Selection.Font
    .Name = "Calibri"
    .Size = 16
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontMinor
End With
Range("C1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("c1").Select
With Selection.Font
    .Name = "Calibri"
    .Size = 16
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontMinor
End With

 Range("b2:g2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Font.Bold = True
Application.ScreenUpdating = True

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End If


For Each SummWks In ThisWorkbook.Sheets
    Set aCell = SummWks.Rows(2).Find(what:="Date", LookIn:=xlValues, _
    lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    ExitLoop = False

    If Not aCell Is Nothing Then
        Set bCell = aCell

        SummWks.Columns(aCell.Column).NumberFormat = "dd/mm/yyyy;@"

        lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
        SummWks.Rows.Count).End(xlUp).Row

        For i = 2 To lastRow
            With SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i)
                .FormulaR1C1 = .Value
            End With
        Next i

        SummWks.Columns(aCell.Column).AutoFit

        Do While ExitLoop = False
            Set aCell = SummWks.Rows(2).FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do

                SummWks.Columns(aCell.Column).NumberFormat = "dd/mm/yyyy;@"

                lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
                SummWks.Rows.Count).End(xlUp).Row

                For i = 2 To lastRow
                    SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).FormulaR1C1 = _
                    SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).Value
                Next i
            Else
                ExitLoop = True
            End If
        Loop
    End If


With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End If

For Each SummWks In ThisWorkbook.Sheets
    Set aCell = SummWks.Rows(2).Find(what:="Score", LookIn:=xlValues, _
    lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    ExitLoop = False

    If Not aCell Is Nothing Then
        Set bCell = aCell

        SummWks.Columns(aCell.Column).NumberFormat = "0%"

        lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
        SummWks.Rows.Count).End(xlUp).Row

        For i = 2 To lastRow
            With SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i)
                .FormulaR1C1 = .Value
            End With
        Next i

        SummWks.Columns(aCell.Column).AutoFit

        Do While ExitLoop = False
            Set aCell = SummWks.Rows(2).FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do

                SummWks.Columns(aCell.Column).NumberFormat = "0%"

                lastRow = SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & _
                SummWks.Rows.Count).End(xlUp).Row

                For i = 2 To lastRow
                    SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).FormulaR1C1 = _
                    SummWks.Range(Split(SummWks.Cells(, aCell.Column).Address, "$")(1) & i).Value
                Next i
            Else
                ExitLoop = True
            End If
        Loop
    End If
Next

 Next

End Sub

宏来整合子文件夹中每个wkbook的2个不同工作表的数据，并在每个子文件夹的单独工作表中显示结果

2 个答案: