如何动态创建表中列数组，实现多列去重 [英] how to create array with number of columns in sheet dynamically,for remove duplicates in multiple columns

问题描述

我是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

使用此代码时出现错误：过程调用无效enter code herer参数

以下代码用于合并文件夹中所有文件中的数据，并对数据进行排序和删除重复项，最终创建数据透视表

Sub LoopAllFilesInAFolder()

Dim FolderPath As String
Dim Filename As String
Dim lDestLastRow As Long
FolderPath = "D:surekha_internvba macro learningassignmentstudents_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

感谢预付，

推荐答案

使用数组删除重复项

三个条件

• 数组必须声明为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

这篇关于如何动态创建表中列数组，实现多列去重的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！