如何动态创建 sheet 中列数的数组，以删除多列中的重复项
how to create array with number of columns in sheet dynamically,for remove duplicates in multiple columns
我是vba的新手，在这里我解释一下我的情况
1，我想知道如何在 vba 中形成索引为 1
的数组
2,如何给数组去重**
我想删除 sheet 中的多个列，动态地我的意思是如果 sheet 包含 5 行我想给
(1,2,3,4,5)
如果 sheet 包含 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 参数
下面的代码是整理文件夹中所有文件的数据并对数据进行排序并删除重复项最终要创建数据透视表table
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
提前致谢，
请尝试下一个代码。它假定第一行与计算现有列数有关:
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 方法。它，理论上应该接受一个没有任何解决方法的数组，但它不......它似乎期望一个变体数组，不接受包含该数组的单个变体，这不完全符合该方法的记录方式。多年来，这是这种方法的一个已知问题...
使用数组删除重复项
三个条件
- 数组必须声明为
Variant（因为你没有声明）。
- 数组必须基于零（因为你没有）。
- 必须使用
Evaluate 或 () 计算数组（就像您所做的那样）。
还有
- 可以简化引用范围。
- 始终限定您的范围，例如
wsDest.Cells...、wsDest.Range...
几乎没有关系
- 如果您计划仅将
RemoveDuplicates 应用于某些列，则将 VBA 与 Array 函数一起使用将确保 zero-based 数组（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 中创建一个 table（表示 headers，不一定是 Excel Table），从 A1 开始，有 5 行和 4 列。在 2 行或更多行中使用相同的数据（所有列都相同），运行 执行以下过程，看看如何仅保留 'same-data' 行中的一个。它还包括一个可选的 'loop handling'.
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
我是vba的新手，在这里我解释一下我的情况
1，我想知道如何在 vba 中形成索引为 1
的数组
2,如何给数组去重**
我想删除 sheet 中的多个列，动态地我的意思是如果 sheet 包含 5 行我想给 (1,2,3,4,5) 如果 sheet 包含 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 参数
下面的代码是整理文件夹中所有文件的数据并对数据进行排序并删除重复项最终要创建数据透视表table
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
提前致谢，
请尝试下一个代码。它假定第一行与计算现有列数有关:
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 方法。它，理论上应该接受一个没有任何解决方法的数组，但它不......它似乎期望一个变体数组，不接受包含该数组的单个变体，这不完全符合该方法的记录方式。多年来，这是这种方法的一个已知问题...
使用数组删除重复项
三个条件
- 数组必须声明为
Variant（因为你没有声明）。 - 数组必须基于零（因为你没有）。
- 必须使用
Evaluate或()计算数组（就像您所做的那样）。
还有
- 可以简化引用范围。
- 始终限定您的范围，例如
wsDest.Cells...、wsDest.Range...
几乎没有关系
- 如果您计划仅将
RemoveDuplicates应用于某些列，则将VBA与Array函数一起使用将确保 zero-based 数组（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 中创建一个 table（表示 headers，不一定是 Excel Table），从 A1 开始，有 5 行和 4 列。在 2 行或更多行中使用相同的数据（所有列都相同），运行 执行以下过程，看看如何仅保留 'same-data' 行中的一个。它还包括一个可选的 'loop handling'.
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