Question

我想使用VBA从表中删除多个列（删除重复项并应用一些约束）到另一个表中。所有这些如果可能的话，以表格格式。

我是vba的新手，我不知道这是否可行，但我需要的是从下面采用独特的产品商店组合，以便销售额> 0

Product  Store  day     sales
Apple      A   monday     3
Apple      A   tuesday    0
Apple      A   wednesday  4
Apple      B   thursday   7
Pear       A   monday     3
Pear       C   tuesday    0

因此，结果应为：

Product Store  
Apple      A   
Apple      B   
Pear       A

我已经尝试录制宏但结果真的很长......

顺便说一句，数据非常大，所以我认为逐行排列不是一种选择。

Answer 1

试试这个

Sub FilterAndCopy()

 Columns("A:D").Select 'Change to your actual cells that holds the data
 Selection.AutoFilter
 Columns("A:B").Select 'Change to your columns that holds the Products and Store data
 ActiveSheet.Range("$A:$B").RemoveDuplicates Columns:=Array(1, 2), Header :=xlNo 'Change to your columns that holds the Products and Store data
 Range("A1", Cells(Cells(2, 1).End(xlDown).Row, 2)).Select 'Change to your columns that holds the Products and Store data
 Selection.Copy
 Sheets.Add After:=ActiveSheet
 ActiveSheet.Paste

End Sub

Answer 2

以下代码应该有所帮助：

Option Explicit

Sub Demo()
    Application.ScreenUpdating = False             'stop screen flickering
    Application.Calculation = xlCalculationManual  'prevent calculation while execution

    Dim i As Long, lastrow As Long
    Dim dict As Object
    Dim ws As Worksheet

    Set dict = CreateObject("Scripting.Dictionary")
    Set ws = ThisWorkbook.Worksheets("Sheet1")  'change Sheet1 to your worksheet

    With ws
        lastrow = .Range("A" & .Rows.Count).End(xlUp).Row   'get last row with data from Column A

        'get unique records for product and store combined together
        For i = 2 To lastrow
            If .Cells(i, 4).Value <> 0 Then 'consider product only if sales is not 0
                dict(.Cells(i, 1).Value & "|" & .Cells(i, 2).Value) = dict(.Cells(i, 1).Value & "|" & .Cells(i, 2).Value)
            End If
        Next

        With .Range("F2").Resize(dict.Count)    'unique product and store will be displayed from cell F2
            .Value = Application.Transpose(dict.Keys)
            .TextToColumns Destination:=.Cells, DataType:=xlDelimited, Other:=True, OtherChar:="|"
            .Offset(, 2).Resize(dict.Count).Value = Application.Transpose(dict.Items)
        End With
    End With

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

输出如下：

vba：使用表并删除有条件的重复项

2 个答案: