Question

我正在尝试找到将“sheet1”中整列的内容带到“sheet2”的vba代码，如果单元格A1中的值与下面“sheet1”中的一个标题匹配则是我所拥有的远：

Sub searchdata()
Dim lastrow As Long, x As Long

lastcolumn = Sheets("Practice Associations").Cells(Columns.Count,.End(xlToRight)

For y = 1 To lastcolumn
If Sheets("Practice Associations").Cells(y, 1).Value = Sheets("Sheet2").Range("A1").Value Then
    Sheets("Sheet2").Range("A2:A1000").Value = Sheets("Sheet1").Column(x, 1).Value

基本上，我正在尝试构建一个仪表板，如果在搜索框中搜索到的值与表中的某个标题匹配，则该仪表板将提取值列表。任何帮助表示赞赏！提前谢谢。

Answer 1

嗨此代码满足您的要求，因为它复制整个列并将值粘贴到sheet2中相应的匹配列上

Option Explicit

Sub test()

With Excel.Application
    .ScreenUpdating = False
End With

Dim last_col_one, last_col_two As Range
Dim sheet_headers As Range
Dim xl_header As Range
Dim target_headers As Range
Dim cell As Range

With ThisWorkbook.Sheets("Sheet2")
    Set last_col_one = .Cells(1, .Columns.Count).End(xlToLeft)
    Set sheet_headers = .Range(.Cells(1, 1), last_col_one)
End With

With ThisWorkbook.Sheets("Sheet1")
    Set last_col_two = .Cells(1, .Columns.Count).End(xlToLeft)
    Set target_headers = .Range(.Cells(1, 1), last_col_two)
End With

For Each xl_header In sheet_headers
    For Each cell In target_headers
        If cell.Value = xl_header.Value Then
            cell.EntireColumn.Copy
            xl_header.PasteSpecial xlPasteValues
        End If
    Next cell
Next xl_header

With Excel.Application
    .CutCopyMode = False
    .ScreenUpdating = True
End With

End Sub

Answer 2

这应该有效：

Sub Macro3()

myVal = Sheets("Sheet2").Cells(1, 1).Value

t = 1
Found = 0

Do Until Found = 1

If Sheets("Sheet1").Cells(1, t) = myVal Then
Sheets("Sheet1").Columns(t).Copy
Sheets("Sheet2").Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Found = 1
End If
t = t + 1

Loop

End Sub

如果sheet2的单元格中的值与sheet1

2 个答案: