通过 VBA 传输数据 [关闭]

Question

在我有 64 个选项卡的工作簿中，每个工作表都包含与我在每个工作表页面上的付款相关的信息。每个工作表页面的名称位于名为“Tabs”的工作表的A2：A65范围内。

每张worksheet由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

有人可以帮我解决这个问题吗？

我尝试用微观的方式解决问题，我大部分都成功了，但我很难用更宏观的方式解决它。

Answer 1

不确定我是否理解正确...
不管怎样，下面的代码是基于下面的引用：

其实我只是想把所有的资料都复制转过来 写在另一个工作表的白色 背景上。 从这些选项卡，我想将信息复制并粘贴到列 B/I/J/O/P/Q/R

所以我的猜测是你想从所有工作表/选项卡中复制在 B/I/J/O/P/Q/R 列中没有填充颜色的单元格中的信息，除了工作表“选项卡”

其余的解释被忽略了，你图片中红色的信息也被忽略了，因为我不完全理解它。例如：

我想把B/I/J/O/P/Q/R栏的资料复制粘贴到 另一个工作簿，

一个接一个.

我不明白你的意思。因此，代码不会复制到另一个工作簿，而是复制到同一工作簿中有 64 个工作表/标签的新工作表。 （稍后您可以将此新工作表另存为新工作簿）。

首先，复制一个有 64 个工作表/标签的工作簿，然后创建一个新的工作表，将其命名为“结果”，并将任何值放入工作表结果的单元格 A1:G3 中。然后复制/粘贴下面的子程序，然后逐步运行它进行测试。

下面的宏假设它只会在 B 列（Firma）中合并哪些行，数据从第 4 行开始。除了 B 列，没有行被合并。

宏会将所有现有工作表（工作表“Result”和工作表“Tabs”除外）中基于 B 列合并单元格的所有数据复制到工作表结果。因此工作表结果中的数据，从第 4 行开始，A 列只是没有填充颜色的合并单元格数据，并且每个公司名称之间没有空白行。从 B 列到 G 列，没有合并单元格，B 到 G 中的单元格要么有填充颜色，要么没有填充颜色。

Sub test()
Dim shRslt As Worksheet, sh As Worksheet
Dim rg As Range, cell As Range, rgU As Range, rgColor As Range
Dim colS As Integer, colE As Integer
Dim arrCol, col

Application.ScreenUpdating = True

Set shRslt = Sheets("Result")
shRslt.Activate
arrCol = Array("i", "j", "o", "p", "q", "r")

For Each sh In Sheets
If sh.Name <> "Result" And sh.Name <> "Tabs" Then
    Set rg = sh.Range("B4", sh.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlConstants)

    For Each cell In rg.Areas
        colS = cell.Column
        If cell.Interior.ColorIndex = xlNone Then
            If rgU Is Nothing Then Set rgU = cell Else Set rgU = Union(rgU, cell)
           For Each col In arrCol
           colE = Range(col & "1").Column
           Set rgU = Union(rgU, cell.Offset(0, colE - colS).Resize(cell.Rows.Count, 1))
           Next
        End If
    Next
    
rgU.Copy Destination:=shRslt.Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
Set rgU = Nothing

End If
Next sh

'set the data range in column B:G starting from row 4 as rg variable
    With shRslt.UsedRange
        Set rg = .Resize(.Rows.Count - 3, .Columns.Count - 1).Offset(3, 1)
    End With

'get all cells with color as rgColor variable
    Application.FindFormat.Interior.ColorIndex = xlNone
    With rg
        v = .Value
        .ClearContents
        .Replace "", True, xlWhole, , False, , True, False
        Set rgColor = .SpecialCells(xlBlanks)
        .Value = v
    End With
    
'clear the rgColor (the cells with fill color) at once
    rgColor.Clear
    
Application.ScreenUpdating = True

End Sub

逐行运行代码以检查它是否运行正常。

从所有选项卡/工作表复制数据后的示例工作表结果（工作表“结果”本身和工作表“选项卡”除外）

清除带有填充颜色的单元格后的工作表“结果”：