Excel VBA-按标题搜索列并粘贴到新工作表中

Question

我是VBA新手。。。尝试按名称搜索特定列，并将它们粘贴到新工作表中。

到目前为止，我所拥有的似乎很笨重，没有复制或粘贴所需的列，而是我当前剪贴板上的内容！

理想情况下，我可以搜索3个不同的列，并将它们粘贴到新的工作表上。

如有任何帮助，将不胜感激

Dim CheckText As String
Dim CheckRow As Long
Dim FindText As Range
Dim CopyColumn As String
CheckText = “Bsp” 'Bsp is an example header
CheckRow = 1 'Row with desired header
Dim oldsheet As Worksheet
Set oldsheet = ActiveSheet
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Pivot"
oldsheet.Activate
ActiveSheet.Select
'trying here to create a new sheet, name it and go back to the first sheet
Set FindText = Rows(CheckRow).Find(CheckText)
If FindText Is Nothing Then
MsgBox "Bsp not found"
End If
CopyColumn = Cells(CheckRow, FindText.Column).Column
Columns(CopyColumn).Select.Copy
Sheets("Pivot").Select
ActiveSheet.Paste

Answer 1

这只是一个可以根据需要进行调整的通用示例。代码将查找名为Some String的列标题IF如果找到该列，我们接下来确定最后一行，复制该列(向下到最后一行(，然后将该列粘贴到Pivot工作表的单元格A1中。

1. 使用范围变量Found存储列标题属性(即位置(
2. 检查是否真的找到了标头！If Not Found is Nothing(翻译：已找到(
3. 使用Found.Column来引用列索引，因为语法是Cells(Row Index, Column Index)，所以它很好地适应了Cells属性

---

Option Explicit
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<== Sheet that has raw data
Dim LRow As Long, Found As Range
Set Found = ws.Range("A1:Z1").Find("Some String") '<== Header name to search for
If Not Found Is Nothing Then
LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(1, Found.Column), ws.Cells(LRow, Found.Column)).Copy
Sheets("Pivot").Range("A1").PasteSpecial xlPasteValues '<== Sheet to paste data
End If
End Sub

您将要修改Range.Find方法上的一些选项。详细信息可以在这里找到

Answer 2

我最终使用了这段代码，试图搜索另一个标头并复制粘贴它选项显式

Sub Test()

Dim ws As Worksheet
Set ws = ActiveSheet
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Pivot"
ws.Activate
ActiveSheet.Select
Dim LRow As Long, Found As Range
Set Found = ws.Range("A1:EM1").Find("Bsp") '<== Header name to search for

If Not Found Is Nothing Then
LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(1, Found.Column), ws.Cells(LRow, Found.Column)).Copy
Sheets("Pivot").Range("A1").PasteSpecial xlPasteValues '<== Sheet to paste data
End If
ws.Activate
ActiveSheet.Select
Set Found = ws.Range("A1:EM1").Find("Sog")
If Not Found Is Nothing Then
LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(1, Found.Column), ws.Cells(LRow, Found.Column)).Copy
Sheets("Pivot").Range("B1").PasteSpecial xlPasteValues
End If
End Sub