Как редактировать мой код для обработки нескольких диапазонов

Question

Итак, у меня есть этот код, который отлично работает для 1 диапазона.Я мог бы скопировать этот код 20 раз и изменить диапазон, в котором он используется.Но я хотел бы упростить его и сначала разрешить диапазоны флагов цикла, пока они не станут пустыми, а затем использовать диапазоны notempty в этом коде.

Как вы можете видеть в коде, я создал несколько KoRes (1,2,3 ... все добавляют +2 к предыдущему).Эта переменная KoRes используется для определения диапазона rng1, чтобы проверить, является ли этот диапазон пустым, а если не пустым, он будет передавать данные.

Option Explicit
Dim lastRow As Long
Dim db As Worksheet, HistLog As Worksheet
Dim x As String, rng1 As Range
Dim Ko1 As Integer, Ko2 As Integer, Ko3 As Integer, Ko4 As Integer, Ko5 As Integer, KoStmKst As Integer, KoRes1 As Integer, KoDat1 As Integer, KoTemp1 As Integer
Dim Co1 As Integer, Co2 As Integer, Co3 As Integer, Co4 As Integer, Co5 As Integer, Co6 As Integer, Co7 As Integer
Dim Ko1Let As String, Ko2Let As String, Ko3Let As String, Ko4Let As String, Ko5Let As String, Co1Let As String, Co2Let As String, Co3Let As String, Co4Let As String, Co5Let As String, Co6Let As String, Co7Let As String
Dim FiAvRow As Long

Sub HistoryLog()

'// Call sheets
Set db = ThisWorkbook.Sheets("Database")
Set HistLog = ThisWorkbook.Sheets("HistoryLog")

'// Screenupdating off
   Application.ScreenUpdating = False

'// Search columnnumbers and letters
    db.Activate
    KoStmKst = WorksheetFunction.Match("cost", ActiveSheet.Range("1:1"), 0)
    Ko2 = WorksheetFunction.Match("tag", ActiveSheet.Range("1:1"), 0): Ko2Let = Split(Cells(1, Ko2).Address, "$")(1)
    Ko3 = WorksheetFunction.Match("custTag", ActiveSheet.Range("1:1"), 0): Ko3Let = Split(Cells(1, Ko3).Address, "$")(1)
    Ko4 = WorksheetFunction.Match("Plant", ActiveSheet.Range("1:1"), 0): Ko4Let = Split(Cells(1, Ko4).Address, "$")(1)
    Ko5 = WorksheetFunction.Match("Zone", ActiveSheet.Range("1:1"), 0): Ko5Let = Split(Cells(1, Ko5).Address, "$")(1)
    KoRes1 = KoStmKst + 2
    KoRes2 = KoStmKst + 4
    KoRes3 = KoStmKst + 6
    KoRes4 = KoStmKst + 8
    KoRes5 = KoStmKst + 10
    KoRes6 = KoStmKst + 12
    KoRes7 = KoStmKst + 14
    lastRow = Cells(Rows.Count, Ko2Let).End(xlUp).Row
    HistLog.Activate
    Co1 = WorksheetFunction.Match("Number", ActiveSheet.Range("1:1"), 0): Co1Let = Split(Cells(1, Co1).Address, "$")(1)
    Co2 = WorksheetFunction.Match("TAG", ActiveSheet.Range("1:1"), 0): Co2Let = Split(Cells(1, Co2).Address, "$")(1)
    Co3 = WorksheetFunction.Match("CustTAG", ActiveSheet.Range("1:1"), 0): Co3Let = Split(Cells(1, Co3).Address, "$")(1)
    Co4 = WorksheetFunction.Match("Plant Hist", ActiveSheet.Range("1:1"), 0): Co4Let = Split(Cells(1, Co4).Address, "$")(1)
    Co5 = WorksheetFunction.Match("Date", ActiveSheet.Range("1:1"), 0): Co5Let = Split(Cells(1, Co5).Address, "$")(1)
    Co6 = WorksheetFunction.Match("Surface Temp Hist", ActiveSheet.Range("1:1"), 0): Co6Let = Split(Cells(1, Co6).Address, "$")(1)
    Co7 = WorksheetFunction.Match("Status Hist", ActiveSheet.Range("1:1"), 0): Co7Let = Split(Cells(1, Co7).Address, "$")(1)

'// 1e kolom resultaat overzetten
    db.Activate
    Set rng1 = db.Range(Cells(2, KoRes1), Cells(lastRow, KoRes1))
    If WorksheetFunction.CountA(rng1) = 0 Then
        GoTo 1
    Else
'//Transfer data
        For Each x In rng1
            HistLog.Activate
            FiAvRow = Cells(Rows.Count, Co7Let).End(xlUp).Offset(1).Row
            HistLog.Range(Co7Let & FiAvRow) = x
            HistLog.Range(Co2Let & FiAvRow) = db.Cells(x.Row, Ko2).Value
            HistLog.Range(Co3Let & FiAvRow) = db.Cells(x.Row, Ko3).Value
            HistLog.Range(Co4Let & FiAvRow) = db.Cells(x.Row, Ko4).Value
            HistLog.Range(Co5Let & FiAvRow) = db.Cells(1, KoRes1).Value
            HistLog.Range(Co6Let & FiAvRow) = db.Cells(x.Row, KoRes1 - 1).Value
            HistLog.Range(Co1Let & FiAvRow) = (db.Cells(1, KoRes1).Value & "_" & x.Row & "A" & "_")
        Next x
    End If

1:
'// Screenupdating on
        Application.ScreenUpdating = True

End Sub

Я сам нашел решение.После передачи всех данных я просто делаю KoRes1 + 2 и устанавливаю jumppoint (2) над кодом проверки диапазона и зацикливаю его вот так.Я слишком много думал об этом.Если у кого-то есть предложения по передовым методам для этого, не стесняйтесь комментировать.

'// 1e kolom resultaat overzetten
2:
    db.Activate
    Set rng1 = db.Range(Cells(2, KoRes1), Cells(lastRow, KoRes1))
    If WorksheetFunction.CountA(rng1) = 0 Then
        GoTo 1
    Else
'//Transfer data
        For Each x In rng1
            HistLog.Activate
            FiAvRow = Cells(Rows.Count, Co7Let).End(xlUp).Offset(1).Row
            HistLog.Range(Co7Let & FiAvRow) = x
            HistLog.Range(Co2Let & FiAvRow) = db.Cells(x.Row, Ko2).Value
            HistLog.Range(Co3Let & FiAvRow) = db.Cells(x.Row, Ko3).Value
            HistLog.Range(Co4Let & FiAvRow) = db.Cells(x.Row, Ko4).Value
            HistLog.Range(Co5Let & FiAvRow) = db.Cells(1, KoRes1).Value
            HistLog.Range(Co6Let & FiAvRow) = db.Cells(x.Row, KoRes1 - 1).Value
            HistLog.Range(Co1Let & FiAvRow) = (db.Cells(1, KoRes1).Value & "_" & x.Row & "A" & "_")
        Next x
        KoRes1 = KoRes1 + 2
        GoTo 2

    End If

Я хотел бы использовать цикл, который каждый раз делает KoRes + 2, проверьте, не является ли этот диапазон пустым, и если нет, используйте'// передача данных.Если пусто, остановите макрос.