Question

我需要一些帮助以我的代码创建循环

该代码具有两个主要功能：

将常规数据复制并粘贴到另一个工作簿
将员工数据复制并粘贴到另一个工作簿

我想循环我的代码（代码如下所示）。我可以将此代码编写15次，并且可以工作，但我认为循环会更好。我对循环没有任何经验。

因此，当我按下工作表上的按钮时，它将复制常规数据并打开另一个工作簿，然后返回主工作簿并复制员工数据并将其粘贴到另一个工作簿中。

需要打开的工作簿位于F82：F96范围内，因此首先是F82，然后是F83 ...，依此类推，直到到达F96，然后代码必须停止。

总数据始终位于第15和16行。

找到的员工数据与必须打开的工作簿具有相同的字符串。必须将字符串后的行复制并粘贴到其他工作簿中。例如（G82：DI82）。

我有什么

我在单元格（F82）中创建了一个适用于1名员工的代码，下面的代码打开该员工的工作簿，然后复制常规数据，然后找到要粘贴的右列和右行。然后，我粘贴数据，然后将其返回到主工作簿，并复制属于其员工的数据（G82：DI82），然后将此数据粘贴到其他工作簿中。然后保存以关闭打开的工作簿。主要工作簿保持打开状态。

我期望的结果

我需要一个循环来重复代码。因此首先是（F82）中的雇员，然后是（F83）中的雇员，依此类推。

代码：

Private Sub mUpdate_Click()

Dim General As Range
Dim employe1hours As Range
Dim employepaste As Range
Dim employepastehours As Range
Dim CurrentweekColumn As Range
Dim Currentweekpaste As Range

Dim employepath As String
Dim employe1 As String
Dim rowstr As String
Dim Foundrow As Range
Dim Currentweek As String


employepath = "J:\Planning\Medewerkers\"
Currentweek = Range("B7").Value
employe1 = Range("F82").Value
rowstr = Range("A2").Value

    With ActiveWorkbook.Sheets("Planning").Range("14:14")
    Set CurrentweekColumn = .find(what:=Currentweek, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
    End With

        Set General = ActiveWorkbook.Sheets("Planning").Range(Cells(15, CurrentweekColumn.Column), Cells(16, CurrentweekColumn.Offset(0, 106).Column))
        General.Copy

        Workbooks.Open (employepath & employe1 & ".xlsm")

            With ActiveWorkbook.Sheets("Blad1").Range("14:14")
            Set Currentweekpaste = .find(what:=Currentweek, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
            End With

            With ActiveWorkbook.Sheets("Blad1").Range("A:A")
            Set Foundrow = .find(what:=rowstr, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
            End With

            Set employepaste = ActiveWorkbook.Sheets("Blad1").Range(Cells(Foundrow.Row, Currentweekpaste.Column).Address)
            employepaste.PasteSpecial Paste:=xlPasteFormats
            employepaste.PasteSpecial Paste:=xlPasteValues

                Workbooks(rowstr & ".xlsm").Activate
                Set employe1hours = ActiveWorkbook.Sheets("Planning").Range(Cells(82, CurrentweekColumn.Column), Cells(82, CurrentweekColumn.Offset(0, 106).Column))
                employe1hours.Copy

                Workbooks(employe1 & ".xlsm").Activate
                Set employepastehours = ActiveWorkbook.Sheets("Blad1").Range(Cells(Foundrow.Offset(2, 0).Row, Currentweekpaste.Column).Address)
                employepastehours.PasteSpecial Paste:=xlPasteValues

                ActiveWorkbook.Save
                ActiveWorkbook.Close

Answer 1

由于我们无法为您完成所有工作，因此应该让您了解循环的外观：

Option Explicit

Public Sub MyUpdateProcedure()
    Dim Employees As Range 'define the range of employees
    Set Employees = ThisWorkbook.Worksheets("SheetName").Range("F82:F96")

    Dim CurrentWorkbook As Workbook
    Const EmployePath As String = "J:\Planning\Medewerkers\"


    Dim Employe As Range
    For Each Employe In Employees 'loop throug all employees
        'open the workbook
        Set CurrentWorkbook = Workbooks.Open(EmployePath & Employe.Value & ".xlsm")

        With CurrentWorkbook.Sheets("Blad1")
            'your stuff here
        End With


        'your other stuff here

        'save and close workbook
        CurrentWorkbook.Close SaveChanges:=True
    Next Employe
End Sub

请注意，您必须避免使用ActiveWorkbook，而是将打开的工作簿设置为Set CurrentWorkbook = Workbooks.Open之类的变量，然后可以方便地使用它。

还要确保您的Range(…)对象全部具有指定的工作簿/工作表，例如ThisWorkbook.Worksheets("SheetName").Range(…)，否则Excel会猜测您的意思是哪个工作表。

也要注意错误：

Set CurrentWorkbook = Workbooks.Open(EmployePath & Employe.Value & ".xlsm")

如果工作簿不存在，将引发错误，因此您可能想抓住它：

    'open the workbook
    Set CurrentWorkbook = Nothing 'initialize since we are in a loop!
    On Error Resume Next 'next line throws an error if file not found so catch it
    Set CurrentWorkbook = Workbooks.Open(EmployePath & Employe.Value & ".xlsm")
    On Error GoTo 0 'always re-activate error reporting!

    If Not CurrentWorkbook Is Nothing Then
        'file for employee was found
        With CurrentWorkbook.Sheets("Blad1")
            'your stuff here
        End With


        'your other stuff here

        'save and close workbook
        CurrentWorkbook.Close SaveChanges:=True
    Else
        'file for employee was not found
    End If

循环执行多次相同的代码

1 个答案: