已关闭，此问题需要更focused，目前不接受回答。
**要改进此问题吗？**更新问题，使其仅关注editing this post的一个问题。

3天前关闭。
Improve this question
在我的工作簿中有64个选项卡，每个工作表都包含与每个工作表页面上的付款相关的信息。每个工作表页面的名称位于A2：名为“制表符”的工作表的A65范围。
每个工作表由A列和S列之间的信息组成。B列中白色背景上写的公司将在该周支付，而不同颜色的公司将在该周不支付。
从这些选项卡中，我想将B/I/J/O/P/Q/R列中的信息一个接一个地复制和粘贴到另一个工作簿中。我使用“O”列作为分隔信息的参考，因为它只包含将收到付款的公司的付款信息。这使我更容易分隔信息，因为它们也是写在白色背景上的。
事实上，我只是想将所有写在白色背景上的信息复制并转移到另一个工作表中。
在使用ChatGPT时，下面的代码很大程度上解决了我的单个标签的问题。然而，有一个问题我无法克服。正如你在照片中看到的那样，有时候，在列I和J中并不只有一行并排的信息。还有几条信息彼此在下面。当我试图将这些信息复制并粘贴到所需的页面时，我在传输这些信息时遇到了麻烦。

ChatGPT代码

Sub KopyalaYapistir1()

'Kopyalanacak verilerin bulunduğu çalışma kitabını aç
Workbooks.Open "C:\Users\emir.DEMTA\Desktop\Dosya\Ödeme Listesi.xlsb"

'Kopyalanacak verilerin bulunduğu çalışma sayfasını tanımla
Dim kopyalanacakSayfa As Worksheet
Set kopyalanacakSayfa = Workbooks("Ödeme Listesi.xlsm").Worksheets("Çalışma Sayfası")

'Yapıştırılacak hedef sayfayı tanımla
Dim hedefSayfa As Worksheet
Set hedefSayfa = Workbooks("Satınalma Çalışma.xlsm").Worksheets("Hedef Sayfa")

'Her satır için döngü yap
Dim satir As Integer
satir = 7 'ilk satır

Do While satir <= 214 'son satır
    'O sütunu doluysa
    If kopyalanacakSayfa.Cells(satir, "O").Value <> "" Then
        'Kopyalanacak verileri ayrı ayrı tanımla
        Dim bDegeri As String
        Dim ıDegeri As String
        Dim jDegeri As String
        Dim oDegeri As String
        Dim pDegeri As String
        Dim qDegeri As String

        bDegeri = kopyalanacakSayfa.Cells(satir, "B").Value
        ıDegeri = kopyalanacakSayfa.Cells(satir, "I").Value '& " " & kopyalanacakSayfa.Cells(satir + 1, "I").Value
        jDegeri = kopyalanacakSayfa.Cells(satir, "J").Value '& " " & kopyalanacakSayfa.Cells(satir + 1, "J").Value
        oDegeri = kopyalanacakSayfa.Cells(satir, "O").Value
        pDegeri = kopyalanacakSayfa.Cells(satir, "P").Value
        qDegeri = kopyalanacakSayfa.Cells(satir, "Q").Value

        'Hedef sayfadaki ilk boş hücreyi bul ve kopyalanan verileri ilgili sütunlara yapıştır
        Dim hedefHucre As Range
        Set hedefHucre = hedefSayfa.Cells(hedefSayfa.Rows.Count, "A").End(xlUp).Offset(1, 0)
        hedefHucre.Value = bDegeri
        hedefHucre.Offset(0, 1).Value = ıDegeri
        hedefHucre.Offset(0, 2).Value = jDegeri
        hedefHucre.Offset(0, 3).Value = oDegeri
        hedefHucre.Offset(0, 4).Value = pDegeri
        hedefHucre.Offset(0, 5).Value = qDegeri
    End If
    satir = satir + 1 'bir sonraki satıra geç
Loop

    'Kopyalanacak verilerin bulunduğu çalışma kitabını kapat
    Workbooks("Ödeme Listesi.xlsm").Close

End Sub

有没有人可以帮助我解决这个问题？
我试着用微观的方法来解决这个问题，我大部分都成功了，但我很难用更宏观的方法来解决这个问题。