如何解决VBA 从列表中删除 Excel 列
我经常下载一个包含 1000 多列的 excel 文件,其中许多是不需要的,手动删除它们非常乏味。我发现一个 VBA 会删除不需要的列,但这种方法不适合大列表。
所以,我有一个工作簿,其中 Sheet1 是从 A 到 BQM 运行的数据和列。我获取了所有标题名称并将它们转换为 Sheet2 (A2:A1517) 中的 A 列。我想我正在寻找一种方法让 vba 查看 Sheet2 中的表格并删除 Sheet1 上任何匹配的标题标题。有什么建议么?我是新手,所以慢慢来。
Router
解决方法
EDIT2:现在实际工作... 编辑:添加了匹配列的重新定位
使用 Match()
:
Sub DeleteAndSortColumnsByHeader()
Dim wsData As Worksheet,wsHeaders As Worksheet,mHdr,n As Long
Dim wb As Workbook,arr,rngTable As Range,addr
Dim nMoved As Long,nDeleted As Long,nMissing As Long
Set wb = ThisWorkbook 'for example
Set wsData = wb.Sheets("Products")
Set wsHeaders = wb.Sheets("Headers")
'get array of required headers
arr = wsHeaders.Range("A1:A" & _
wsHeaders.Cells(Rows.Count,"A").End(xlUp).Row).Value
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'shift the data over so we can move columns into the required order
Set rngTable = wsData.Range("a1").CurrentRegion 'original data
addr = rngTable.Address 'remember the position
rngTable.EntireColumn.Insert
Set rngTable = wsData.Range(addr) 'restore to position before insert
'loop over the headers array
For n = 1 To UBound(arr,1)
mHdr = Application.Match(arr(n,1),wsData.Rows(1),0) 'current position of this header
If IsError(mHdr) Then
'required header does not exist - do nothing,or add a column with that header?
wsData.Cells(1,n).Value = arr(n,1)
nMissing = nMissing + 1
Else
wsData.Columns(mHdr).Cut wsData.Cells(1,n) 'found: move
nMoved = nMoved + 1
End If
Next n
'delete everything not found and moved
With rngTable.Offset(0,rngTable.Columns.Count)
nDeleted = Application.CountA(.Rows(1)) 'count remaining headers
Debug.Print "Clearing: " & .Address
.EntireColumn.Delete
End With
Application.Calculation = xlCalculationAutomatic
Debug.Print "moved",nMoved
Debug.Print "missing",nMissing
Debug.Print "deleted",nDeleted
End Sub
,
在 Sheet2 中,请清除显示要删除的列名称的单元格。 并运行以下代码。
Sub DeleteColumnByHeader()
For Col = 1517 To 2 Step -1
If Range("Sheet2!A" & Col).Value == "" Then
Columns(Col).EntireColumn.Delete
End If
Next
End Sub
,
按标题删除列
-
DeleteColumnsByHeaders
过程将完成这项工作。 - 调整常量部分中的值。
- 剩下的两个程序在这里是为了方便测试。
测试
- 要测试该过程,请添加一个新工作簿并确保其中包含工作表
Sheet1
和Sheet2
。 - 添加一个模块并将完整代码复制到其中。
- 运行
PopulateSourceRowRange
和PopulateDestinationColumnRange
过程。查看工作表以查看示例设置。 - 现在运行
DeleteColumnsByHeaders
过程。查看目标工作表 (Sheet1
),看看发生了什么:所有不需要的列都已删除,只留下“数百”列。
Option Explicit
Sub DeleteColumnsByHeaders()
Const sName As String = "Sheet2"
Const sFirst As String = "A2"
Const dName As String = "Sheet1"
Const dhRow As String = "A2:BQM2"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the Source Column Range (unwanted headers).
Dim srg As Range
Dim srCount As Long
With wb.Worksheets(sName).Range(sFirst)
Dim slCell As Range
Set slCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*",xlFormulas,xlPrevious)
If slCell Is Nothing Then Exit Sub
srCount = slCell.Row - .Row + 1
Set srg = .Resize(srCount)
End With
' Write the values from the Source Range to the Source Data Array.
Dim sData As Variant
If srCount = 1 Then
ReDim sData(1 To 1,1 To 1): sData(1,1) = srg.Value
Else
sData = srg.Value
End If
' Create a reference to the Destination Row Range.
Dim drg As Range: Set drg = wb.Worksheets(dName).Range(dhRow)
' Combine all cells containing unwanted headers into the Union Range.
Dim urg As Range
Dim dCell As Range
For Each dCell In drg.Cells
If IsNumeric(Application.Match(dCell,sData,0)) Then
If urg Is Nothing Then
Set urg = dCell
Else
Set urg = Union(urg,dCell)
End If
End If
Next dCell
Application.ScreenUpdating = False
' Delete the entire columns of the Union Range.
If Not urg Is Nothing Then
urg.EntireColumn.Delete
End If
Application.ScreenUpdating = True
End Sub
' Source Worksheet ('Sheet1'):
' Writes the numbers from 1 to 1807 into the cells of the row range
' and to five rows below.
Sub PopulateSourceRowRange()
With ThisWorkbook.Worksheets("Sheet1").Range("A2:BQM2").Resize(6)
.Formula = "=COLUMN()"
.Value = .Value
End With
End Sub
' Destination Worksheet ('Sheet2'):
' Writes the numbers from 1 to 1807 except the hundreds (100,200,... 1800)
' to the range 'A2:A1790'. The hundreds are the columns you want to keep.
Sub PopulateDestinationColumnRange()
Dim n As Long,r As Long
r = 1
With ThisWorkbook.Worksheets("Sheet2")
For n = 1 To 1807
If n Mod 100 > 0 Then
r = r + 1
.Cells(r,"A").Value = n
End If
Next n
End With
End Sub
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。