查找特定数据并复制内容直到行结束
我已经分别维护了两个Excel报告EPC1.xlsx和Control Power Transformers.xlsm 。
我想触发Control Power Transformers.xlsm报告中的一个button点击，它将从EPC1.xlsx “A”列中search"CTPT"项，一旦find需要复制列B和列c的项，直到行结束（在EPC1.xlsx ）并粘贴在Control Power Transformers.xlsm工作簿中
我成功地检索“CTPT”术语的单元格地址，但是如何从邻近的列B和C中select数据？
这就是我所尝试过的
Private Sub CommandButton23_Click() Dim rngX As Range Dim num As String Windows("EPC 1.xlsx").Activate Set rngX = Worksheets("Sheet1").Range("A1:A10000").Find("CTPT", Lookat:=xlPart) num = rngX.Address ' Here we will the get the cell address of CTPT ($A$14) Range(rngX, Range("C" & rngX.Row).End(xlDown)).Copy Windows("Control Power Transformers.xlsm").Activate Sheets("Sheet2").Select ActiveSheet.Range("E2").PasteSpecial (xlPasteValues) End Sub
您需要使用FindNext来查找其他结果，并且“ Offset将帮助您从结果地址中select所需的内容：
Sub test_Karthik() Dim WbEPC As Workbook, _ WbCPT As Workbook, _ WsEPC As Worksheet, _ WsCPT As Worksheet, _ FirstAddress As String, _ WriteRow As Long, _ cF As Range, _ num As String Set WbEPC = Workbooks("EPC 1.xlsx") Set WbCPT = Workbooks("Control Power Transformers.xlsm") Set WsEPC = WbEPC.Sheets("Sheet1") Set WsCPT = WbCPT.Sheets("Sheet2") With WsEPC .Activate With .Range("A1:A10000") 'First, define properly the Find method Set cF = .Find(What:="CTPT", _ After:=ActiveCell, _ LookIn:=xlValues, _ Lookat:=xlPart, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) 'If there is a result, keep looking with FindNext method If Not cF Is Nothing Then FirstAddress = cF.Address Do num = cF.Address ' Here we will the get the cell address of CTPT ($A$14) WsEPC.Range(cF.Offset(0, 1), cF.Offset(0, 2).End(xlDown)).Copy WriteRow = WsCPT.Range("E" & WsCPT.Rows.count).End(xlUp).Row + 1 WsCPT.Range("E" & WriteRow).PasteSpecial (xlPasteValues) Set cF = .FindNext(cF) 'Look until you find again the first result Loop While Not cF Is Nothing And cF.Address <> FirstAddress End If End With End With End Sub
将下面的内容粘贴到示例工作簿中。 下面的代码将有助于使用文件对话框来select两个文件。 它将search单词“CTPT”。 如果是的话，它会将CTPT表中的列值复制到控制文件中。
Sub DetailsFilePath() Dim File1 As String Dim File2 As String Dim findtext As String Dim copyvalues As Long Dim c As Variant Dim wb1 As Workbook Dim wb2 As Workbook Dim ws1 As Worksheet Dim ws2 As Worksheet MsgBox "Open the CTPT file" Application.FileDialog(msoFileDialogFilePicker).Show 'On Error Resume Next ' open the file File1 = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1) MsgBox "Open the Control Power Transformers file" Application.FileDialog(msoFileDialogFilePicker).Show File2 = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1) Set wb1 = Workbooks.Open(Filename:=File1) Set ws1 = wb1.Worksheets("sheet1") Set wb2 = Workbooks.Open(Filename:=File2) Set ws2 = wb2.Worksheets("sheet1") findtext = "CTPT" With ws1.Columns(1) Set c = .Find(findtext, LookIn:=xlValues) If Not c Is Nothing Then copyvalues = c.Column ws2.Columns(2).Value = ws1.Columns(2).Value ws2.Columns(3).Value = ws1.Columns(3).Value End If End With wb1.Close savechanges:=True wb2.Close savechanges:=True End Sub