Question

我正在尝试在两个单独的工作表（＆＃34; Participaciones Bond＆＃34;＆＃34; Participaciones VAL＆＃34;）中对帐户进行排序，并将两个工作表中的客户复制到工作表中的一列中＃34;会谈摘要＆＃34;和＃34; resumen＆＃34;中的另一列中的客户，而不是另一列中的客户。

在两个工作表中复制这些客户的部分运行良好，但我无法弄清楚为什么第二个if语句不起作用。

'Patribond= i, patriVal= j
i = 5
j = 5
Do While Worksheets("Participaciones Bond ").Cells(i, "A") <> ""
    j = 5
    Do While Worksheets("Participaciones VAL ").Cells(j, "A") <> ""
        If Worksheets("Participaciones Bond ").Cells(i, 1).Value = Worksheets("Participaciones VAL ").Cells(j, 1).Value Then
            Worksheets("Participaciones Bond ").Activate
            Sheets("Participaciones Bond ").Select
            Worksheets("Participaciones Bond ").Rows(i).Copy Sheets("Resumen").Range("A1048576").End(xlUp).Offset(1, 0)
            Exit Do
        End If
        j = j + 1

        'personas en patribond que no aparecen en patrival'
        If Worksheets("Participaciones VAL ").Cells(j, 1) = "" Then
            Worksheets("Resumen").Activate
            'Cells(3, "H").Value = "We got into the second IF"'
            Worksheets("Participaciones Bond ").Activate
            Range(Cells(i, "A"), Cells(i, "E")).Copy
            Worksheets("Resumen").Activate
            Range(Cells(i, "G"), Cells(i, "X")).Select
            Worksheets("Resumen").Paste
        End If
    Loop
    i = i + 1
Loop

Answer 1

我不知道您有哪些数据可供测试，但我认为您的代码工作正常，即：它正在输入两个If条件。但是你检查它的方法是写入一个单元格（＆＃34; H3＆＃34;）当你用指令复制整行时可能会被覆盖

 with Worksheets("Participaciones Bond ").Rows(i).Copy Sheets("Resumen").Range("A1048576").End(xlUp).Offset(1, 0)

我就是这样做的。

您无需更改选择内容，也无需激活工作表，以便从/向其进行复制。

此外，对于两张纸中的记录和仅在第一张纸中的记录，我都会以相同的方式复制，而不是复制整行，而是将源限制在包含数据的范围内。这样您就不会意外地覆盖工作表右侧的列。并且您的记录将被复制到＆＃34; Resumen＆＃34;的顶部。表格也是。

为了做到这一点，我改变了

  Rows(i).Copy.

到

  Range("A" & i, "E" & i).Copy.

我还添加了对三张纸的引用，但这并不是必需的。

Dim wBond           As Worksheet
Dim wVal            As Worksheet
Dim wRes            As Worksheet

Set wBond = Worksheets("Participaciones Bond ")
Set wVal = Worksheets("Participaciones Val ")
Set wRes = Worksheets("Resumen")

i = 5
Do While Not IsEmpty(wBond.Cells(i, "A"))
    j = 5
    Do While Not IsEmpty(wVal.Cells(j, "A"))

        If wBond.Cells(i, 1).Value = wVal.Cells(j, 1).Value Then
            '   La persona está en ambas hojas: copiar en la columna correspondiente
            wBond.Range("A" & i, "E" & i).Copy wRes.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            Exit Do
        End If

        j = j + 1

        If IsEmpty(wVal.Cells(j, 1)) Then
            wBond.Range("A" & i, "E" & i).Copy wRes.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0)
        End If

    Loop
    i = i + 1
Loop

Answer 2

我在晚餐前开始编写此代码并被卡住了。现在我吃饱了，但线程可能已超出我的目标。基本上，我按照你的描述编写了我自己的代码。它与你所采用的方法不同，但后来我陷入第二个IF的意义，无法弄明白。请运行我的数据代码并告诉我它是否值得继续。

代码会在Bond表格中显示您的所有姓名，并将数据复制到Resumen表格。如果在Val表中找到副本，它会将10列Val数据（我想知道，这是一个逻辑错误）复制到A列，否则它会从Bond表中复制10列数据（我认为两者都是相同的，因此我更愿意将所有这些从债券表复制到K列。代码比你的简单，因此更容易调整。看一看。测试你的数据，看看你得到了什么。

Sub CopyCustomers()
    ' 06 Apr 2017

    Dim WsBond As Worksheet
    Dim WsVal As Worksheet
    Dim WsRes As Worksheet
    Dim Rl As Long                          ' WsBond last row
    Dim R As Long                           ' WsBond row
    Dim Rv As Long                          ' found row in WsVal
    Dim Rr As Long                          ' next row in WsRes
    Dim Cr As Long                          ' column in WsRes
    Dim Cust As String                      ' customer name from WsBond
    Dim Rng As Range                        ' range to be copied to WsRes

    Set WsBond = Sheets("Participaciones Bond ")
    Set WsVal = Sheets("Participaciones VAL ")
    Set WsRes = Sheets("Resumen")

    Rr = 5
    Application.EnableEvents = False
    With WsBond
        Rl = .Cells(.Rows.Count, 1).End(xlUp).Row
        For R = 5 To Rl
            Cust = .Cells(R, 1).Value
            Rv = 0
            On Error Resume Next
            Rv = WorksheetFunction.Match(Cust, WsVal.Columns(1), 0)
            ' no need to copy the entire row of 140K cells (takes too much time)
            ' in each of the following rows 10 stands for 10 columns being copied
            If Err = 0 Then
                Set Rng = WsVal.Range(WsVal.Cells(Rv, 1), WsVal.Cells(Rv, 10))
                Cr = 1                      ' paste to column A
            Else
                Set Rng = .Range(.Cells(R, 1), .Cells(R, 10))
                Cr = 11                     ' paste to column K
            End If
            Rng.Copy Destination:=WsRes.Cells(Rr, Cr).Resize(1, 10)
            Rr = Rr + 1
            Err.Clear
        Next R
    End With
    Application.EnableEvents = True
End Sub

Val表中可能有名称不在债券表中。它们很容易添加，但这需要另一个循环，而不是另一个IF。您可能也不喜欢Resumen表中的行排列。易于调整。我想你可以自己做。你不想要10列，你不想要A栏，你不同意K栏 - 所有这些都很容易调整。如果您需要帮助，我将很乐意为您提供帮助。

Answer 3

假设您的数据在第4行中有标题，您可以利用Autofilter()并执行以下操作

Option Explicit

Sub main()
    Dim commonRng As Range, uniqueBondRng As Range, uniqueValRng As Range

    GetCommonAndUniqueData "Participaciones Bond", "Participaciones VAL", commonRng, uniqueBondRng
    GetCommonAndUniqueData "Participaciones VAL", "Participaciones Bond", commonRng, uniqueValRng

    If Not commonRng Is Nothing Then commonRng.Copy Worksheets("Resumen").Range("a1")
    If Not uniqueBondRng Is Nothing Then uniqueBondRng.Copy Worksheets("Resumen").Range("B1")
    If Not uniqueValRng Is Nothing Then uniqueValRng.Copy Worksheets("Resumen").Range("C1")        
End Sub

Sub GetCommonAndUniqueData(sht1Name As String, sht2Name As String, commonRng As Range, uniqueRng As Range)
    Dim cell As Range

    With Worksheets(sht1Name)
        With .Range("A4", .Cells(.Rows.Count, 1).End(xlUp))
            .AutoFilter Field:=1, Criteria1:=GetValues(sht2Name), Operator:=xlFilterValues
            With .Offset(1).Resize(.Rows.Count - 1)
                If Application.WorksheetFunction.Subtotal(103, .Cells) > 0 Then Set commonRng = .SpecialCells(xlCellTypeVisible)
                .Parent.AutoFilterMode = False
                If commonRng Is Nothing Then
                    Set uniqueRng = .Cells
                Else
                    Set uniqueRng = .Cells(.Rows.Count + 1, 1).Resize(1)
                    For Each cell In .Cells
                        If Intersect(commonRng, cell) Is Nothing Then Set uniqueRng = Union(uniqueRng, cell)
                    Next
                    Set uniqueRng = Intersect(uniqueRng, .Cells)
                End If
            End With
        End With
    End With
End Sub


Function GetValues(shtName As String) As Variant
    With Worksheets(shtName)
        GetValues = Application.Transpose(.Range("A5", .Cells(.Rows.Count, 1).End(xlUp)).Value)
    End With
End Function

无法弄清楚为什么VBA代码没有进入If语句

3 个答案: