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

【问题标题】：Excel VBA - search columns by header and paste into new sheetExcel VBA - 按标题搜索列并粘贴到新工作表中
【发布时间】：2018-11-03 23:42:52
【问题描述】：

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

【问题讨论】：

标签： excel vba copy copy-paste paste

【解决方案1】：

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

使用范围变量Found 来存储您的列标题属性（即位置）
检查是否确实找到了标头！ If Not Found is Nothing（翻译：找到）
使用Found.Column 引用与Cells 属性完美匹配的列索引，因为语法为Cells(Row Index, Column Index)

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 方法的一些选项。详情可见here

【讨论】：

感谢您回复我。您的代码很有效。

【解决方案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

【讨论】：