如何解决如何在工作表中动态创建具有列数的数组，以删除多列中的重复项
我是vba的新手，在这里我解释一下我的情况
1，我想知道如何在 vba 中形成索引为 1 的数组
2、如何给数组去掉重复项**
我想删除工作表中的多列，动态我的意思是如果工作表包含 5 行我想给 (1,2,3,4,5) 如果工作表包含 3--(1,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,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,Header:=xlYes
'ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1,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
提前感谢 n，
解决方法
请尝试下一个代码。它假设第一行与计算现有列数相关：
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",LastCol1)).RemoveDuplicates Columns:=(darray),Header:=xlYes 'it works in this way,too
End Sub
问题看起来属于 RemoveDuplicates 方法。它理论上应该接受一个没有任何解决方法的数组，但它没有......它似乎期望一个变体数组，不接受包含该数组的单个变体，这与记录方法的方式不完全一致。多年来，这是这种方法的一个已知问题...
使用数组删除重复项
三个条件
- 必须将数组声明为
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
版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。
