Используйте переменные при циклировании. (например: первый цикл Variable1 = значение1 и во втором переменном цикла1 = значение2)

У меня есть небольшая программа, которую я хочу пропустить в нескольких листах. Но проблема в коде, который у меня есть, есть переменные, которые необходимо изменить с листа на рабочий лист. Поэтому я не могу использовать команду loop.

В моем коде (см. Ниже) я установил их как VARIABLE1, VARIABLE2 и т. Д. Значения этих параметров должны быть изменены при первом запуске, во второй раз и так далее.

Пример:

В первой петле VARIABLE1 должен быть равен "CMGLT" а во втором контуре VARIABLE1 должен быть равен "CMCLT" .

 Function WorksheetExists(WSName As String) As Boolean On Error Resume Next WorksheetExists = Worksheets(WSName).Name = WSName On Error GoTo 0 End Function Sub BOI() If Not WorksheetExists("VARIABLE1") Then '---------------VARIABLE1 Sheets.Add.Name = "VARIABLE1" '---------------VARIABLE1 Else 'START GEN CODE 'Set CMGLT as activesheet!!!! Worksheets("VARIABLE1").Activate '---------------VARIABLE1 'Checking company code Dim celltxt As String celltxt = ActiveSheet.Range("G8").Text If InStr(1, celltxt, "VARIABLE2") Then '---------------VARIABLE2 'unmerge entire sheet ActiveSheet.Cells.UnMerge 'unwrap entire sheet ActiveSheet.Cells.WrapText = False 'set short date format for up to 3000 rows ActiveSheet.Range("A2", "A3000").NumberFormat = "dd/mm/yyyy" 'delete blank rows in column A Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'delete rows from 1 to 6 Rows("1:6").EntireRow.Delete 'deleting all rows below "total" Dim LR As Long, Found As Range LR = Range("A" & Rows.Count).End(xlUp).Row Set Found = Columns("A").Find(What:="Total", LookIn:=xlValues, lookat:=xlWhole) If Not Found Is Nothing Then Rows(Found.Row & ":" & LR).Delete 'changing column width of B column Range("B1").ColumnWidth = 12 'changing column width of A column Range("A1").ColumnWidth = 12 'changing formating of B column to General Range("B:B").NumberFormat = "General" 'CHANGE THIS AS APPROPRIATELY!!!! Range("B1").Value = "VARIABLE3" '------------------------------------'VARIABLE3 'getting date as value Range("C1").Select ActiveCell.FormulaR1C1 = "=TEXT(RC[-2],""DD.MM.YYYY"")" 'copying company code and date until last row of data Dim LRow As Long LRow = ActiveSheet.UsedRange.Rows.Count Range("B1").AutoFill Destination:=Range("B1:B" & LRow) Range("C1").AutoFill Destination:=Range("C1:C" & LRow) 'pasting date as value Columns("C:C").Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False 'deleting blank rows in amount column On Error Resume Next Range("W:W").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'coping data to "UP" sheet Dim Lastrow As Integer Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row Range("C1:C" & Lastrow).Copy Destination:=Worksheets("Up").Range("A" & Rows.Count).End(xlUp).Offset(1) Range("B1:B" & Lastrow).Copy Destination:=Worksheets("Up").Range("C" & Rows.Count).End(xlUp).Offset(1) Range("C1:C" & Lastrow).Copy Destination:=Worksheets("Up").Range("D" & Rows.Count).End(xlUp).Offset(1) Range("Q1:Q" & Lastrow).Copy Destination:=Worksheets("Up").Range("F" & Rows.Count).End(xlUp).Offset(1) Range("Q1:Q" & Lastrow).Copy Destination:=Worksheets("Up").Range("I" & Rows.Count).End(xlUp).Offset(1) Range("W1:W" & Lastrow).Copy Destination:=Worksheets("Up").Range("O" & Rows.Count).End(xlUp).Offset(1) 'END GEN CODE Else MsgBox ("VARIABLE1 Validation Mismatch. Exiting...") '---------------VARIABLE1 Exit Sub End If End If End Sub 

отредактирован для некоторых улучшений скорости кода после совместного использования OP файла примера

вы можете BOI что ваш BOI sub принимает переменные строки в качестве параметров и вызывается посредством основного подцифрового цикла через все из них

как следует

 Option Explicit Sub main() '<~~ main sub calling BOI inside a loop Dim VARIABLE1 As Variant, VARIABLE2 As Variant, VARIABLE3 As Variant Dim i As Long VARIABLE1 = Array("CMGLT", "CMCLT", "VARIABLE3", "VARIABLE4") '<~~ "main" array containing all VARIABLE1 needed values VARIABLE2 = Array("114486744", "104074162", "VARIABLE2-3", "VARIABLE2-4") ' <~~ VARIABLE2 array, with elements corresponding by position to VARIABLE1 ones -> total elements number must match VARIABLE1 one VARIABLE3 = Array("VARIABLE3-1", "VARIABLE3-2", "VARIABLE3-3", "VARIABLE3-4") ' <~~ VARIABLE3 array, with elements corresponding by position to VARIABLE1 ones -> total elements number must match VARIABLE1 one For i = 0 To UBound(VARIABLE1) ' <~~ loop over your VARIABLE1 array Call BOI(VARIABLE1(i), VARIABLE2(i), VARIABLE3(i)) ' <~~ and pass VARIABLE2 and VARIABLE3 corresponding elements, too Next i End Sub Sub BOI(VARIABLE1 As Variant, VARIABLE2 As Variant, VARIABLE3 As Variant) Dim LR As Long Dim found As Range If Not WorksheetExists(CStr(VARIABLE1)) Then '---------------VARIABLE1 Sheets.Add.Name = CStr(VARIABLE1) Else 'START GEN CODE With Worksheets(CStr(VARIABLE1)) '---------------VARIABLE1 '<~~ instead of selecting/activating wanted sheet, tell VBA to consider it as implicit object for any subsequent methods or properties calls 'Checking company code If InStr(1, .Range("G8"), CStr(VARIABLE2)) Then '---------------VARIABLE2 'unmerge entire sheet .UsedRange.UnMerge '<~~ VBA reads this statement as "Worksheets(CStr(VARIABLE1)).UsedRange.Unmerge" 'unwrap entire sheet .UsedRange.WrapText = False '<~~ act on usedrange only, to be faster LR = .Range("A" & .Rows.Count).End(xlUp).Row '<~~ store last non empty row index 'clearing all rows below "Total" Set found = .Range("A2:A" & LR).SpecialCells(xlCellTypeConstants, xlTextValues).Find(what:="Total", LookIn:=xlValues, lookat:=xlWhole) '<~~ search into relevant cells only If Not found Is Nothing Then .Rows(found.Row & ":" & LR).Clear '<~~ Clear() is faster then Delete() 'set short date format for up to 3000 rows LR = .Range("A" & .Rows.Count).End(xlUp).Row '<~~ update last non empty row index (you possibly deleted some rows before) ' .Range("A2", "A3000").NumberFormat = "dd/mm/yyyy" .Range("A2:A" & LR).SpecialCells(xlCellTypeConstants, xlNumbers).NumberFormat = "dd/mm/yyyy" '<~~ act on relevant cells only 'delete blank rows in column A .Range("A1:A" & LR).SpecialCells(xlCellTypeBlanks).EntireRow.Delete '<~~ avoid deleting blank rows after the last non empty one 'delete rows from 1 to 6 .Rows("1:6").EntireRow.Delete LR = .Range("A" & .Rows.Count).End(xlUp).Row '<~~ update last non empty row index (you possibly deleted some rows before) 'changing column width of B column .Range("B1").ColumnWidth = 12 'changing column width of A column .Range("A1").ColumnWidth = 12 'changing formating of B column to General .Range("B1:B" & LR).NumberFormat = "General" '<~~ act on relevant cells only 'CHANGE THIS AS APPROPRIATELY!!!! .Range("B1").Value = VARIABLE3 '------------------------------------'VARIABLE3 'getting date as value .Range("C1").FormulaR1C1 = "=TEXT(RC[-2],""DD.MM.YYYY"")" '<~~ instead of selecting and then acting on selection, just act directly on the range object 'copying company code and date until last row of data .Range("B1").AutoFill Destination:=Range("B1:B" & LR) .Range("C1").AutoFill Destination:=Range("C1:C" & LR) 'pasting date as value ' .Columns("C:C").Select ' Selection.Copy ' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ ' :=False, Transpose:=False ' Application.CutCopyMode = False With .Columns("C:C").SpecialCells(xlCellTypeFormulas) '<~~ this is equivalent to what above, but much faster .Value = .Value End With 'deleting blank rows in amount column On Error Resume Next .Range("W1:W" & LR).SpecialCells(xlCellTypeBlanks).EntireRow.Delete '<~~ act on relevant cells only On Error GoTo 0 '<~~ always remember to set standard error trapping right after you don't need skipping errors anymore 'coping data to "UP" sheet LR = .Cells(Rows.Count, 1).End(xlUp).Row '<~~ update last non empty row index (you possibly deleted some rows before) CopyValues .Range("C1:C" & LR), Worksheets("Up"), "A" '<~~ take advantage of a sub to avoid repeating same code CopyValues .Range("B1:B" & LR), Worksheets("Up"), "C" '<~~ take advantage of a sub to avoid repeating same code CopyValues .Range("C1:C" & LR), Worksheets("Up"), "D" '<~~ take advantage of a sub to avoid repeating same code CopyValues .Range("Q1:Q" & LR), Worksheets("Up"), "F" '<~~ take advantage of a sub to avoid repeating same code CopyValues .Range("Q1:Q" & LR), Worksheets("Up"), "I" '<~~ take advantage of a sub to avoid repeating same code CopyValues .Range("W1:W" & LR), Worksheets("Up"), "O" '<~~ take advantage of a sub to avoid repeating same code 'END GEN CODE Else MsgBox (VARIABLE1 & " Validation Mismatch. Exiting...") '---------------VARIABLE1 Exit Sub End If End With End If End Sub Sub CopyValues(sourceRng As Range, targetSht As Worksheet, targetCol As String) With targetSht .Range(targetCol & .Rows.Count).End(xlUp).Offset(1).Resize(sourceRng.Rows.Count).Value = sourceRng.Value End With End Sub Function WorksheetExists(WSName As String) As Boolean On Error Resume Next WorksheetExists = Worksheets(WSName).Name = WSName On Error GoTo 0 End Function 

где я также сделал еще немного (из всех возможных) небольших оптимизаций кода

  • Использование цикла для выбора диапазона изменения с помощью VBA
  • VBA: если ссылаться на другой лист, он не найден
  • Как заставить VBA выполнять те же действия при изменении критериев, пока не попадет в пустую ячейку?
  • Условный цикл с текущей суммой пропускает значения
  • Поиск 1000 номеров в 1000 книгах
  • Python, цикл высказываний, тянущихся от excel
  • Нужна помощь в циклическом перемещении по группам опционных кнопок при копировании / прошлом содержимом ячейки
  • Как протестировать несколько аргументов командной строки (sys.argv
  • MatLab: динамическая итерация через ячейки с помощью надстройки Excel COM
  • Phpexcel заменит нулевое значение пустой строкой
  • Петля отлично работает на одном листе, с трудом пробираясь через книгу.
  • Interesting Posts

    Excel Solver с использованием строк

    Excel: проблемы с циклическим использованием столбцов с использованием цикла

    Я хотел бы, чтобы даты отображались на оси X, а цветная категория отображалась на оси Y, Excel

    Как пропустить строки и записать в определенные ячейки в программе для работы с электронными таблицами, используя Python

    Условное форматирование таблицы на основе таблицы на основе другой ячейки таблицы для дат начала проекта

    Открытие файлов Excel из C #

    Сопоставьте 2 столбца в excel, чтобы показать значение в третьем столбце

    Как получить код sql из сводной таблицы Excel 2007

    как очистить эту ошибку программирования в getCellData в основе ключевого слова для selenium webdriver?

    делая макрос vba более эффективным

    Каков самый быстрый способ экспорта DataTable в C # в MS Excel?

    Вычисление области программирования с использованием двойного меридиана

    Извлечение определенного значения ячейки из Excel или Power BI

    VBA-провайдер не может быть найден с помощью формата accdb

    Новая рабочая книга Excel, созданная макросом Outlook, не сохраняется в каталоге

    Давайте будем гением компьютера.