时间戳

首页 > 解决方案 > 循环多次执行相同的代码

excel - 循环多次执行相同的代码

问题描述

我需要一些帮助才能从我的代码中创建一个循环

该代码有两个主要功能：

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

我想循环我的代码（代码如下所示）。我可以编写此代码 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

标签： excelvba

解决方案

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

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

推荐阅读