Цикл в VBA - переход от последнего ряда на одном листе к первому ряду на следующем листе

Question

Я пытаюсь автоматизировать процесс копирования / вставки значений из нескольких листов в один. Я нахожусь в некотором затруднении, когда у меня есть l oop, но когда я запускаю макрос, он перезаписывает значения друг на друга в том же столбце, куда записываются данные. Мой код ниже.

Sub Main()
    MedRT_EPC Sheets("Chemical Structure (14)")
    MedRT_EPC Sheets("Enzymes (19)")
    MedRT_EPC Sheets("Diuretics (5)")
    MedRT_EPC Sheets("Imaging Agents (12)")
    MedRT_EPC Sheets("Vitamins (27)")
End Sub
Sub MedRT_EPC(ws As Worksheet)

' Copy EPC cells Macro
 Dim bottomL As Integer
 Dim x As Integer
 bottomL = ws.Range("I" & Rows.Count).End(xlUp).Row: x = 1


 Dim c As Range
 For Each c In ws.Range("I:I" & bottomI)
 If c.Value = "EPC" Then
 c.EntireRow.Copy Worksheets("sheet4").Range("A" & x)
 x = x + 1
 End If
 Next c

End Sub

Я пытался добавить это:

 Dim LastTargetRow As Long
' code here
 With ws
    LastTargetRow = .Range("I" & Rows.Count).End(xlUp).Row + 1
 End With
' code here

Но мне не повезло. Если бы кто-то мог помочь, это было бы здорово!

Answer 1

Ваша проблема в том, что "х" не меняется. Попробуйте приведенный ниже код. Заполните x1, x2, x3, x4 и x5 нужными числами.

   Sub Main()
        MedRT_EPC Sheets("Chemical Structure (14)",x1)
        MedRT_EPC Sheets("Enzymes (19)",x2)
        MedRT_EPC Sheets("Diuretics (5)",x3)
        MedRT_EPC Sheets("Imaging Agents (12)",x4)
        MedRT_EPC Sheets("Vitamins (27)"x5)
    End Sub
    Sub MedRT_EPC(ws As Worksheet, x as Integer)

' Copy EPC cells Macro
 Dim bottomL As Integer
 bottomL = ws.Range("I" & Rows.Count).End(xlUp).Row: x = 1


 Dim c As Range
 For Each c In ws.Range("I:I" & bottomI)
 If c.Value = "EPC" Then
 c.EntireRow.Copy Worksheets("sheet4").Range("A" & x)

 End If
 Next c

End Sub

Answer 2

Как я уже говорил выше, Autofilter будет быстрее (или с использованием Find), но если вы придерживаетесь al oop, главное не запускать каждый лист в строке 1 для вашего диапазона вставки.

Sub MedRT_EPC(ws As Worksheet)

' Copy EPC cells Macro
Dim bottomL As Long, x As Long

bottomL = ws.Range("I" & Rows.Count).End(xlUp).Row

Dim c As Range

For Each c In ws.Range("I2:I" & bottomL) 'or I1 as applicable
    If c.Value = "EPC" Then
        x = Worksheets("sheet4").Range("I" & Rows.Count).End(xlUp).Row + 1
        c.EntireRow.Copy Worksheets("sheet4").Range("A" & x)
    End If
Next c

End Sub