Question

我有各种不同员工姓名的工作簿，其中包含不同的项目编号和工作时间。我正在尝试将这些项目编号过滤到包含特定项目编号的整个行的主文件（zmaster）。我需要Excel来筛选匹配的目录（特定文件夹包含所有员工小时文件）并将这些匹配复制到zmaster文件中。过滤器是主文件的单元格A1（例如，链接图片示例中为300000）。图1是主文件，图2是员工小时文件的示例。

this article（1） https://i.stack.imgur.com/OKs68.png（2）

此外，如果Excel会过滤掉重复项（例如，第30周的完全相同的小时数，并且主文件中已有的员工名称很可能是重复的并且应该被忽略），那就太棒了。

我是Excel vba的新手，发现/调整了以下宏。第一个复制目录中的所有数据并将其放入主文件中。第二个过滤掉与单元格A1匹配的项目编号。但是，这需要2个步骤，当我第二次运行第一个宏时，它还将收集已输入主文件的数据。此外，我的第二个宏将匹配放在与员工小时文件中相同的行号中，因此删除位于同一行的主文件中的早期观察（例如，项目编号100000放在员工的第2行中）小时文件因此复制到主文件中的第2行，删除主文件的指示符行。）

第一个宏：

Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String

Filepath = ("C:\test\”)
MyFile = Dir(Filepath)

Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsx" Then
Exit Sub
End If

Workbooks.Open (Filepath & MyFile)
Range("A2:L9").Copy

ActiveWorkbook.Close
erow = Blad1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))

MyFile = Dir
Loop
End Sub

第二个宏：

Sub finddata()
Dim projectnumber As Integer
Dim finalrow As Integer
Dim i As Integer

Sheets("Blad1").Range("A1:H9").ClearContents
projectnumber = Sheets("Blad1").Range("A1").Value
finalrow = Sheets("Blad1").Range("A30").End(x1Up).row

For i = 1 To finalrow
    If Cells(i, 1) = projectnumber Then
        Range(Cells(i, 1), Cells(i, 12)).Copy
        Range("A100").End(x1Up).Offset(1, 0).PasteSpecial x1pasteformulasandnumberformats
        End If
Next i
Range("A1").Select
End sub

希望一切都清楚，并提前感谢！

Answer 1

这应该有用。

打开目录中的每个文件
检查文件名是否不是zmaster，并且它包含xlsx
遍历当前文件中的每一行，然后将复制范围合并到主文件

复制到主文件的最后一行加1，这是第一个空行

Option Explicit

Sub CopyToMasterFile()

    Dim MasterWB As Workbook
    Dim MasterSht As Worksheet
    Dim MasterWBShtLstRw As Long
    Dim FolderPath As String
    Dim TempFile
    Dim CurrentWB As Workbook
    Dim CurrentWBSht As Worksheet
    Dim CurrentShtLstRw As Long
    Dim CurrentShtRowRef As Long
    Dim CopyRange As Range
    Dim ProjectNumber As String


    FolderPath = "C:\test\"
    TempFile = Dir(FolderPath)

    Dim WkBk As Workbook
    Dim WkBkIsOpen As Boolean

    'Check is zmaster is open already
    For Each WkBk In Workbooks
        If WkBk.Name = "zmaster.xlsx" Then WkBkIsOpen = True
    Next WkBk

    If WkBkIsOpen Then
        Set MasterWB = Workbooks("zmaster.xlsx")
        Set MasterSht = MasterWB.Sheets("Blad1")
    Else
        Set MasterWB = Workbooks.Open(FolderPath & "zmaster.xlsx")
        Set MasterSht = MasterWB.Sheets("Blad1")
    End If

    ProjectNumber = MasterSht.Cells(1, 1).Value



    Do While Len(TempFile) > 0

        'Checking that the file is not the master and that it is a xlsx
        If Not TempFile = "zmaster.xlsx" And InStr(1, TempFile, "xlsx", vbTextCompare) Then

            Set CopyRange = Nothing

            'Note this is the last used Row, next empty row will be this plus 1
            With MasterSht
                MasterWBShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
            End With

            Set CurrentWB = Workbooks.Open(FolderPath & TempFile)
            Set CurrentWBSht = CurrentWB.Sheets("Sheet1")

            With CurrentWBSht
                CurrentShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
            End With

            For CurrentShtRowRef = 1 To CurrentShtLstRw

             If CurrentWBSht.Cells(CurrentShtRowRef, "A").Value = ProjectNumber Then

               'This is set to copy from Column A to Column L as per the question

               If CopyRange Is Nothing Then
                 'If there is nothing in Copy range then union wont work
                 'so first row of the work sheet needs to set the initial copyrange
                  Set CopyRange = CurrentWBSht.Range("A" & CurrentShtRowRef & _
                                                ":L" & CurrentShtRowRef)
                Else
                  'Union is quicker to be able to copy from the sheet once
                  Set CopyRange = Union(CopyRange, _
                                        CurrentWBSht.Range("A" & CurrentShtRowRef & _
                                                            ":L" & CurrentShtRowRef))
               End If  ' ending   If CopyRange Is Nothing ....
             End If ' ending  If CurrentWBSht.Cells....

            Next CurrentShtRowRef

            CopyRange.Select

            'add 1 to the master file last row to be the next open row
            CopyRange.Copy MasterSht.Cells(MasterWBShtLstRw + 1, 1)

            CurrentWB.Close savechanges:=False

        End If     'ending            If Not TempFile = "zmaster.xlsx" And ....

        TempFile = Dir

    Loop

End Sub

Excel将特定数据单元从多个工作簿复制到主文件

1 个答案: