EXCEL的VBA求助

夏季

Sub 统计单()
Dim wsCurrent As Worksheet
Dim wsSource As Worksheet
Dim searchDate As Date
Dim searchYear As Integer
Dim searchMonth As Integer
Dim lastRowSource As Long
Dim lastRowCurrent As Long
Dim i As Long, j As Long
Dim foundMatch As Boolean

' 设置当前工作表和源数据工作表
Set wsCurrent = ThisWorkbook.ActiveSheet
Set wsSource = ThisWorkbook.Sheets("入住明细")

' 获取要搜索的日期和月份
searchDate = wsCurrent.Range("C2").Value
searchYear = Year(searchDate)
searchMonth = Month(searchDate)

' 清除当前工作表中D列的可能存在的旧数据（假设从D6开始）
lastRowCurrent = wsCurrent.Cells(wsCurrent.Rows.Count, "D").End(xlUp).Row
If lastRowCurrent >= 6 Then ' 假设从第6行开始有旧数据
    wsCurrent.Range("D6:D" & lastRowCurrent).ClearContents
End If

' 初始化当前工作表的下一行索引（从D6开始）
lastRowCurrent = 6

' 遍历源数据工作表的每一行
lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRowSource
    ' 检查单元格是否包含日期且符合搜索条件
    If IsDate(wsSource.Cells(i, "A").Value) Then
        Dim cellDate As Date
        cellDate = wsSource.Cells(i, "A").Value
        If Year(cellDate) < searchYear Or _
           (Year(cellDate) = searchYear And Month(cellDate) <= searchMonth) Then

            ' 在当前工作表的B列中查找匹配项
            foundMatch = False
            For j = 2 To wsCurrent.Cells(wsCurrent.Rows.Count, "B").End(xlUp).Row
                If wsCurrent.Cells(j, "B").Value = wsSource.Cells(i, "G").Value Then
                    ' 找到匹配项，复制数据
                    wsCurrent.Cells(j, "D").Value = wsSource.Cells(i, "C").Value
                    ' 如果需要复制更多列，可以在这里添加
                    ' ...
                    foundMatch = True
                    Exit For ' 找到匹配项后退出内层循环
                End If
            Next j

            ' 如果没有找到匹配项，并且需要处理这种情况（比如添加到当前工作表的末尾）
            ' 可以在这里添加代码
            ' ...

            ' 注意：如果不需要处理未找到匹配项的情况，可以省略相关代码

            ' 如果需要总是将数据添加到当前工作表的末尾（不考虑B列的匹配）
            ' 可以使用下面的代码替换内层循环和foundMatch的逻辑
            ' wsCurrent.Cells(lastRowCurrent, "D").Value = wsSource.Cells(i, "C").Value
            ' lastRowCurrent = lastRowCurrent + 1

        End If
    End If
Next i

End Sub

询问一下，这个VBA公式，能复制过来到D列，但是匹配项不只1个，多个他会覆盖。怎么让他不覆盖呢又会根据B列的所在行开始填入而不是全部堆叠在D列

MoMo21

要善于借助AI的力量
要解决这个问题，需要修改代码，使其在找到匹配项时，将数据插入到相应的行，而不是覆盖已有数据。可以通过检查目标单元格是否为空，如果不为空，则找到下一个空行来插入数据。
以下是修改后的代码示例：

[Visual Basic] 纯文本查看 复制代码

Sub 统计单()
    Dim wsCurrent As Worksheet
    Dim wsSource As Worksheet
    Dim searchDate As Date
    Dim searchYear As Integer
    Dim searchMonth As Integer
    Dim lastRowSource As Long
    Dim lastRowCurrent As Long
    Dim i As Long, j As Long
    Dim foundMatch As Boolean
    Dim currentRow As Long

    ' 设置当前工作表和源数据工作表
    Set wsCurrent = ThisWorkbook.ActiveSheet
    Set wsSource = ThisWorkbook.Sheets("入住明细")

    ' 获取要搜索的日期和月份
    searchDate = wsCurrent.Range("C2").Value
    searchYear = Year(searchDate)
    searchMonth = Month(searchDate)

    ' 清除当前工作表中D列的可能存在的旧数据（假设从D6开始）
    lastRowCurrent = wsCurrent.Cells(wsCurrent.Rows.Count, "D").End(xlUp).Row
    If lastRowCurrent >= 6 Then ' 假设从第6行开始有旧数据
        wsCurrent.Range("D6:D" & lastRowCurrent).ClearContents
    End If

    ' 初始化当前工作表的下一行索引（从D6开始）
    lastRowCurrent = 6

    ' 遍历源数据工作表的每一行
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRowSource
        ' 检查单元格是否包含日期且符合搜索条件
        If IsDate(wsSource.Cells(i, "A").Value) Then
            Dim cellDate As Date
            cellDate = wsSource.Cells(i, "A").Value
            If Year(cellDate) < searchYear Or _
               (Year(cellDate) = searchYear And Month(cellDate) <= searchMonth) Then

                ' 在当前工作表的B列中查找匹配项
                foundMatch = False
                For j = 2 To wsCurrent.Cells(wsCurrent.Rows.Count, "B").End(xlUp).Row
                    If wsCurrent.Cells(j, "B").Value = wsSource.Cells(i, "G").Value Then
                        ' 找到匹配项，检查D列是否已有数据
                        currentRow = j
                        Do While wsCurrent.Cells(currentRow, "D").Value <> ""
                            currentRow = currentRow + 1
                        Loop
                        ' 复制数据到第一个空单元格
                        wsCurrent.Cells(currentRow, "D").Value = wsSource.Cells(i, "C").Value
                        ' 如果需要复制更多列，可以在这里添加
                        ' ...
                        foundMatch = True
                        Exit For ' 找到匹配项后退出内层循环
                    End If
                Next j

                ' 如果没有找到匹配项，并且需要处理这种情况（比如添加到当前工作表的末尾）
                ' 可以在这里添加代码
                ' ...

                ' 注意：如果不需要处理未找到匹配项的情况，可以省略相关代码

                ' 如果需要总是将数据添加到当前工作表的末尾（不考虑B列的匹配）
                ' 可以使用下面的代码替换内层循环和foundMatch的逻辑
                ' wsCurrent.Cells(lastRowCurrent, "D").Value = wsSource.Cells(i, "C").Value
                ' lastRowCurrent = lastRowCurrent + 1

            End If
        End If
    Next i

End Sub

这个修改后的代码在找到匹配项后，会检查目标单元格是否为空，如果不为空，则找到下一个空行来插入数据，从而避免覆盖已有数据。希望这能解决你的问题。

夏季

MoMo21 发表于 2024-8-8 17:09
要善于借助AI的力量
要解决这个问题，需要修改代码，使其在找到匹配项时，将数据插入到相应的行 ...

我这个代码就是AI写的，我疯狂问他，他就是达不到我要求！！！

lisongmei

你不如发你想实现的功能，让坛友从新给你写一个。。。你这一看就是ai生成的。