寻找代码以从导入到excel的大型列列表中删除匹配值

问题描述 投票：-1回答：2

我正在寻找代码来替换我在下面发布的代码的底部，这将有助于删除2列之间找到的所有重复值（包括用于确定是否存在重复的值），然后继续执行其余列以继续重复搜索。

我有2个选项卡，一个带有按钮的选项卡，用于运行收集月份和年份字段的用户窗体，以及一个选项卡，其中包含从相应的2个文件转储到所选月份和年份的数据。

HOPE数据被转储到A，D，G，J等列中，步长为3到31次（一个月中每个日期的一组数据）。 SP数据被转储到B，E，H，K等列中，步长为3到31次（一个月中每个日期的一组数据）。这意味着列A和B将具有HOPE和SP数据，列C将为空，D和E将具有HOPE和SP数据，并且F将为空。

我移动数据的代码很长而且不复杂，不需要花太多时间，所以我并不那么担心。

耗时的任务是比较每个日期的HOPE和SP列，以从两列中删除匹配对。

下面的变量e到位，因为有2个组合框，有可能产生2个错误。它不会在第一次错误后立即结束sub，而是检查所有错误，然后结束sub。

该子项比较最多6位数字值而没有文本。

Private Sub CommandButton1_Click()

Dim month As String, year As String, lrA As Long, lrB As Long, a As Integer, b As Integer, e As Integer, i As Integer, x As Integer

e = 0
If ComboBox1.Value = "" Then
    ComboBox1.BackColor = vbRed
    ComboBox1.SetFocus
    e = 1
End If
If ComboBox2.Value = "" Then
    ComboBox2.BackColor = vbRed
    ComboBox2.SetFocus
    e = 1
End If

If e = 1 Then
    GoTo ES
End If

month = ComboBox1.Value
year = ComboBox2.Value

Unload UserForm1

Workbooks.Open ("\\filelocation\HOPE - " & month & " " & year & ".xlsx")
With ThisWorkbook.Worksheets("Data Dump")
    x = 1
' 1
    i = 3
    .Range("A1") = "HOPE"
    Do
        .Range("A" & .Cells(.Rows.Count, x).End(xlUp).Row + 1) = ActiveWorkbook.Worksheets("Sheet1").Range("A" & i)
        i = i + 1
    Loop While i < ActiveWorkbook.Worksheets("Sheet1").Cells(ActiveWorkbook.Worksheets("Sheet1").Rows.Count, 1).End(xlUp).Row + 1
    i = 3
    Do
        .Range("A" & .Cells(.Rows.Count, x).End(xlUp).Row + 1) = ActiveWorkbook.Worksheets("Sheet1").Range("B" & i)
        i = i + 1
    Loop While i < ActiveWorkbook.Worksheets("Sheet1").Cells(ActiveWorkbook.Worksheets("Sheet1").Rows.Count, 2).End(xlUp).Row + 1
    i = 3
    Do
        .Range("A" & .Cells(.Rows.Count, x).End(xlUp).Row + 1) = ActiveWorkbook.Worksheets("Sheet1").Range("C" & i)
        i = i + 1
    Loop While i < ActiveWorkbook.Worksheets("Sheet1").Cells(ActiveWorkbook.Worksheets("Sheet1").Rows.Count, 3).End(xlUp).Row + 1
    .Columns(x).RemoveDuplicates Columns:=Array(1)
' 2
    x = x + 3
    .Range("D1") = "HOPE"
    i = 3
    Do
        .Range("D" & .Cells(.Rows.Count, x).End(xlUp).Row + 1) = ActiveWorkbook.Worksheets("Sheet1").Range("B" & i)
        i = i + 1
    Loop While i < ActiveWorkbook.Worksheets("Sheet1").Cells(ActiveWorkbook.Worksheets("Sheet1").Rows.Count, 2).End(xlUp).Row + 1
    i = 3
    Do
        .Range("D" & .Cells(.Rows.Count, x).End(xlUp).Row + 1) = ActiveWorkbook.Worksheets("Sheet1").Range("C" & i)
        i = i + 1
    Loop While i < ActiveWorkbook.Worksheets("Sheet1").Cells(ActiveWorkbook.Worksheets("Sheet1").Rows.Count, 3).End(xlUp).Row + 1
    i = 3
    Do
        .Range("D" & .Cells(.Rows.Count, x).End(xlUp).Row + 1) = ActiveWorkbook.Worksheets("Sheet1").Range("D" & i)
        i = i + 1
    Loop While i < ActiveWorkbook.Worksheets("Sheet1").Cells(ActiveWorkbook.Worksheets("Sheet1").Rows.Count, 4).End(xlUp).Row + 1
    .Columns(x).RemoveDuplicates Columns:=Array(1)
' 3
    x = x + 3
    .Range("G1") = "HOPE"
    i = 3
    Do
        .Range("G" & .Cells(.Rows.Count, x).End(xlUp).Row + 1) = ActiveWorkbook.Worksheets("Sheet1").Range("C" & i)
        i = i + 1
    Loop While i < ActiveWorkbook.Worksheets("Sheet1").Cells(ActiveWorkbook.Worksheets("Sheet1").Rows.Count, 3).End(xlUp).Row + 1
    i = 3
    Do
        .Range("G" & .Cells(.Rows.Count, x).End(xlUp).Row + 1) = ActiveWorkbook.Worksheets("Sheet1").Range("D" & i)
        i = i + 1
    Loop While i < ActiveWorkbook.Worksheets("Sheet1").Cells(ActiveWorkbook.Worksheets("Sheet1").Rows.Count, 4).End(xlUp).Row + 1
    i = 3
    Do
        .Range("G" & .Cells(.Rows.Count, x).End(xlUp).Row + 1) = ActiveWorkbook.Worksheets("Sheet1").Range("E" & i)
        i = i + 1
    Loop While i < ActiveWorkbook.Worksheets("Sheet1").Cells(ActiveWorkbook.Worksheets("Sheet1").Rows.Count, 5).End(xlUp).Row + 1
    .Columns(x).RemoveDuplicates Columns:=Array(1)
' This continues up to 31 using the same steps as above.
End With
ActiveWorkbook.Close False

Workbooks.Open ("\\filelocation\SP - " & month & " " & year & ".xlsx")
With ThisWorkbook.Worksheets("Data Dump")
' 1
    x = 2
    i = 3
    .Range("B1") = "SP - 01"
    Do
        .Range("B" & .Cells(.Rows.Count, x).End(xlUp).Row + 1) = ActiveWorkbook.Worksheets("Sheet1").Range("A" & i)
        i = i + 1
    Loop While i < ActiveWorkbook.Worksheets("Sheet1").Cells(ActiveWorkbook.Worksheets("Sheet1").Rows.Count, 1).End(xlUp).Row + 1
' 2
    x = x + 3
    i = 3
    .Range("E1") = "SP - 02"
    Do
        .Range("E" & .Cells(.Rows.Count, x).End(xlUp).Row + 1) = ActiveWorkbook.Worksheets("Sheet1").Range("B" & i)
        i = i + 1
    Loop While i < ActiveWorkbook.Worksheets("Sheet1").Cells(ActiveWorkbook.Worksheets("Sheet1").Rows.Count, 2).End(xlUp).Row + 1
' 3
    x = x + 3
    i = 3
    .Range("H1") = "SP - 03"
    Do
        .Range("H" & .Cells(.Rows.Count, x).End(xlUp).Row + 1) = ActiveWorkbook.Worksheets("Sheet1").Range("C" & i)
        i = i + 1
    Loop While i < ActiveWorkbook.Worksheets("Sheet1").Cells(ActiveWorkbook.Worksheets("Sheet1").Rows.Count, 3).End(xlUp).Row + 1
' This continues up to 31 using the same steps as above.
End With
ActiveWorkbook.Close False

If month = "February" Or month = "April" Or month = "June" Or month = "September" Or month = "November" Then
    Worksheets("Data Dump").Range("CM:CN") = ""
End If

With Worksheets("Data Dump")
    x = 1
    Do
        lrA = .Cells(Rows.Count, x).End(xlUp).Row
        lrB = .Cells(Rows.Count, x + 1).End(xlUp).Row
        For b = lrB To 2 Step -1
            If .Cells(b, x + 1).Value = "" Then
                .Cells(b, x + 1).Delete
                GoTo nextB
            Else

            End If

            For a = lrA To 2 Step -1
                If .Cells(b, x + 1).Value <> .Cells(a, x).Value Then

                Else
                    .Cells(a, x).Delete
                    .Cells(b, x + 1).Delete
                    GoTo nextB
                End If
            Next a
nextB:
        Next b
        x = x + 3
    Loop While x < 93
End With

ES:
End Sub

在sub的底部是列之间的比较，以确定是否存在重复值。它会移除两列中的所有匹配数字（A和B开始），然后再继续比较其他列（D和E，G和H等）。有没有更好的方法来进行这种比较？ .RemoveDuplicates不起作用，因为它留下一个重复值并删除其余值，而我想删除列之间的任何匹配数字。当数据移动时，已经处理了列中的重复值，因此已经移除的对没有可能剩下一个应该被删除的值，但不能因为它在第一次旋转后不匹配。

此代码也存在一些问题，即插入（或阻止）某些单元向上移动，以便在数字之间存在空白单元格。我不确定这是从哪里来的，但会继续测试。

看来，在比较列的代码之前，所有内容都正确导入。比较完成后，某些与HOPE列相关的列之间存在空白，并且多个数字被错误地移动到空白列。

似乎在进行比较之前激活已将数据转储到其中的工作表会降低它的速度。使用.Activate不切换到工作表可以更快地完成公平的保证金。我从上面的代码中删除了.Activate;它以前直接在工作表“数据转储”的声明中用于比较代码。

我已经确认所有导入都正确完成并删除了重复项。但是，行94的列E左侧的值从SP列向右移动了一个。 （因此，F94，I94等）因其无法理解的原因而具有价值。在E列之后的某些数字之间仍然存在差距，尤其是在HOPE专栏中。我想这个代码的某些部分可能会将SP列号移到HOPE列中。假期后需要进一步测试。

excel vba excel-vba
2个回答
0
投票

你可以做出一些明显的改进。最重要的一个：不要在你的.Cells(.Rows.Count, x).End(xlUp).Row + 1循环中做像Do这样的事情。这样就必须每次计算。而是使用变量来保存该值（无论你想要计算什么）并在循环中使用变量。

0
投票

我通过简化代码并在删除单元格时将单元格移位来解决所有问题。没有更多的空白单元格或单元格移动到它们不应该进入的列。它仍然不是很快，但是这可以完美地完成工作，而前面的代码仍有过多的错误。

With Worksheets("Data Dump")
    x = 1
    Do
        lrA = .Cells(.Rows.Count, x).End(xlUp).Row
        lrB = .Cells(.Rows.Count, x + 1).End(xlUp).Row
        For b = lrB To 2 Step -1
            For a = lrA To 2 Step -1
                If .Cells(a, x).Value = .Cells(b, x + 1).Value Then
                    .Cells(a, x).Delete (xlShiftUp)
                    .Cells(b, x + 1).Delete (xlShiftUp)
                    Exit For
                End If
            Next a
        Next b
        x = x + 3
    Loop While x < 92 ' 91 is the last (31st) day that needs to be calculated.
    .Activate
End With

这看起来似乎是摆脱2列之间的所有匹配值而不删除找到匹配数据的整行的最佳方法。其他方法可能是以各种其他方式使用.Find或.Match来查找匹配数据并删除它和基础数据，但这看起来像是最有效和最有效的工作。

下一站，试图看看是否有办法加快速度。

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.