如何在工作表中动态创建具有列数的数组，以删除多列中的重复项

Posted 2023-03-27

【中文标题】如何在工作表中动态创建具有列数的数组，以删除多列中的重复项

【英文标题】：how to create array with number of columns in sheet dynamically,for remove duplicates in multiple columns

【发布时间】：2021-07-19 15:45:48

【问题描述】：

我是 vba 新手，在这里我解释一下我的情况 1，我想知道如何在 vba 中用索引 1 形成数组 2、如何给数组去重复**

我想删除工作表中的多个列，动态我的意思是如果工作表包含我想提供的 5 行 (1,2,3,4,5) 如果工作表包含 3--(1,2,3)

这是我的代码：

Dim darray() As Integer
 For i = 1 To LastCol1
            ReDim Preserve darray(i)
            darray(i) = i
               Next i

wsDest.Range("A1" & ":" & Cells(LastRow1, LastCol1).Address).RemoveDuplicates Columns:=(darray), Header:=xlYes
wsDest.Range("A1" & ":" & Cells(LastRow1, LastCol1).Address).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes

使用此代码我得到错误：无效的过程调用 oenter code herer 参数

下面的代码是整理文件夹中所有文件的数据并对数据进行排序并删除重复项最终要创建数据透视表

Sub LoopAllFilesInAFolder()

Dim FolderPath As String
Dim Filename As String
Dim lDestLastRow As Long
FolderPath = "D:\surekha_intern\vba macro learning\assignment\students_data_a3\"
Set wsDest = Workbooks("VBA_A3.xlsm").Worksheets("sheet1")
Filename = Dir(FolderPath)
While Filename <> ""
    
   
    'Debug.Print Filename
    'Workbooks.Open Filename:=FolderPath & Filename
    Set wb = Workbooks.Open(FolderPath & Filename)
    If WorksheetFunction.CountA(ActiveSheet.UsedRange) = 0 And ActiveSheet.Shapes.Count = 0 Then
        Debug.Print Filename; " is empty"
    Else
       
    
    Dim LastRow As Long
     Dim Lastrow_te As Long
    With wb.Sheets(1)
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'down
       Lastrow_te = .Range("A99999").End(xlUp).Row
        'Rows.Count, "A"
        MsgBox Lastrow_te
    End With
     Dim LastCol As Integer
    With wb.Sheets(1)
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
       ' MsgBox LastCol
    End With

     lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(0).Row
   ' MsgBox lDestLastRow
    
    'Range("a1:a10").Copy
    'Range("a1:a10").PasteSpecial
    'Application.CutCopyMode = False
    If lDestLastRow = 1 Then
    'MsgBox "HI" '.Range("A" & LastRow & LastCol)'"A" & lastRow & ":" & Cells(lastRow, lastCol).Address
    wb.Sheets("Sheet1").Range("A1" & ":" & Cells(LastRow, LastCol).Address).Copy   '"A" & LastRow & LastCol ----"A" & LastRow, LastCol
    wsDest.Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
    Else
    wb.Sheets("Sheet1").Range("B1" & ":" & Cells(LastRow, LastCol).Address).Copy
    Workbooks("VBA_A3.xlsm").Sheets("sheet1").Range("A" & lDestLastRow + 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    'MsgBox wsDest.Range("A" & lDestLastRow)
    'wb.Sheets("Sheet1").Range("A" & LastRow & LastCol).Copy Destination:=wsDest.Range(A & lDestLastRow)
    
    End If
    
    


        
    End If
   ' ActiveSheet.Close
    wb.Close False
   Filename = Dir
Wend
Workbooks("VBA_A3.xlsm").Save
             
 Dim LastRow1 As Long
    With wsDest
        LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row 'down
        'Rows.Count, "A"
      ' MsgBox LastRow
    End With
     Dim LastCol1 As Integer
    With wsDest
        LastCol1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
      ' MsgBox LastCol
    End With
'SORTING
With wsDest.Sort
    .SortFields.Add Key:=Range("A1:A" & LastRow), Order:=xlAscending
    .SetRange Range("A1" & ":" & Cells(LastRow1, LastCol1).Address)
    .Header = xlYes
    .Apply
End With
'duplicates remove
 ' Dim darray() As Integer
 'For i = 1 To LastCol1
         '   ReDim Preserve darray(i)
           '  darray(i) = i
              '  Next i
                'MsgBox darray()
                
                
'wsDest.Range("A1" & ":" & Cells(LastRow1, LastCol1).Address).RemoveDuplicates Columns:=(darray), Header:=xlYes
'ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
'TEXT EFFECTS
 Dim colm As String
 
Select Case LastCol1

Case 1
colm = "a1"
Case 2
colm = "b1"
Case 3
colm = "c1"
Case 4
colm = "d1"
Case 5
colm = "e1"
End Select

 wsDest.Range("a1:" & colm).Interior.ColorIndex = 5
 wsDest.Range("a1:" & colm).Font.Bold = True
 wsDest.Range("a1:" & colm).Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlContinuous
 wsDest.Range("a1:" & colm).Font.Size = 15
'CREATE PIVOT
'Sheets.Add
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Sheet1!R1C1:R39C4", Version:=xlPivotTableVersion12).CreatePivotTable _
        TableDestination:="Sheet6!R3C1", TableName:="PivotTable2", DefaultVersion _
        :=xlPivotTableVersion12
    Sheets("Sheet6").Select
    Cells(3, 1).Select
    ActiveWorkbook.ShowPivotTableFieldList = True
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("Subject")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveSheet.PivotTables("PivotTable2").AddDataField ActiveSheet.PivotTables( _
        "PivotTable2").PivotFields("marks"), "Sum of marks", xlSum
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("Student name")
        .Orientation = xlPageField
        .Position = 1
    End With

MsgBox "Process done"


End Sub

提前感谢，

【问题讨论】：

首先要获得资格Cells:wsDest.Range("A1" & ":" & wsDest.Cells(LastRow1, LastCol1).Address)...

能否分享完整的前面代码（从Sub...()开始）？您可以随时edit您的问题。

您真的要谈论 5 行 吗？实际上，它们是列吗？如果是，您是要删除所有现有列中的重复项，还是只删除其中一些列中的重复项？

所有现有列基于工作表包含的列，而不是像硬编码一样的固定列计数。我想动态给出。

【参考方案1】：

使用数组删除重复项

三个条件

数组必须声明为Variant（因为您没有）。 数组必须基于

零

（您没有这样做）。 必须使用 Evaluate 或 () 评估数组（就像您所做的那样）。

还有

可以简化引用范围。 始终限定您的范围，例如wsDest.Cells..., wsDest.Range...

几乎不相关

如果您打算仅将RemoveDuplicates 应用于某些列，则将VBA 与Array 函数一起使用将确保从零开始的数组（Option Base 相关）例如dArray = VBA.Array(1, 3, 4)。

快速修复

Sub removeDupes()
    Dim darray() As Variant: ReDim darray(0 To LastCol1 - 1)
    For i = 0 To LastCol1 - 1
        darray(i) = i + 1
    Next i
    wsDest.Range("A1", wsDest.Cells(LastRow1, LastCol1)) _
        .RemoveDuplicates Columns:=(darray), Header:=xlYes
End Sub

另一个例子

添加新工作簿。添加一个模块。将代码复制到模块中。在Sheet1 创建一个表（表示标题，不一定是Excel Table），从A1 开始，有5 行4 列。在 2 行或更多行中使用相同的数据（所有列都相同），运行以下过程并查看如何仅保留一个“相同数据”行。它还包括一个可选的“循环处理”。

Option Explicit

Sub removeDupes()
    Dim LastRow1 As Long: LastRow1 = 5
    Dim LastCol1 As Long: LastCol1 = 4
    Dim arr As Variant: ReDim arr(0 To LastCol1 - 1)
    Dim i  As Long
    For i = 1 To LastCol1
        arr(i - 1) = i
    Next i
    Sheet1.Range("A1", Sheet1.Cells(LastRow1, LastCol1)) _
        .RemoveDuplicates Columns:=(arr), Header:=xlYes
End Sub

【参考方案2】：

请尝试下一个代码。它假定第一行与计算现有列数相关：

Sub testRemoveDupl()
 Dim wsDest As Worksheet, LastCol1 As Long, lastRow1 As Long, darray()

 Set wsDest = ActiveSheet 'use here your necessary sheet!

 LastCol1 = wsDest.cells(1, wsDest.Columns.count).End(xlToLeft).Column
 lastRow1 = wsDest.Range("A" & wsDest.rows.count).End(xlUp).row

 darray = Evaluate("TRANSPOSE(ROW(1:" & LastCol1 & "))")

 wsDest.Range("A1", wsDest.cells(lastRow1, LastCol1)).RemoveDuplicates Columns:=Evaluate(darray), Header:=xlYes
 'wsDest.Range("A1", wsDest.cells(lastRow1, LastCol1)).RemoveDuplicates Columns:=(darray), Header:=xlYes 'it works in this way, too
End Sub

问题似乎属于RemoveDuplicates 方法。它理论上应该接受一个没有任何解决方法的数组，但它没有......它似乎期望一个变体数组，不接受包含该数组的单个变体，这不完全符合记录方法的方式。多年来，这种方法一直是一个已知问题......