追加片頁眉/標題每個搜索結果

-1

我想這個數據追加到每個搜索結果知道哪些元件屬於哪個表。

循環看起來像這樣的搜索：

Set rFound = .Find(What:=strName, LookIn:=xlValues, LookAt:=xlWhole) 
If Not rFound Is Nothing Then 
    firstAddress = rFound.Address 
     Do 
      rFound.EntireRow.Cells(1, "B").Resize(1, 4).Copy 
      OutputWs.Cells(lastRow + 1, 11).PasteSpecial xlPasteAll 
      Application.CutCopyMode = False 
      lastRow = lastRow + 1 
      Set rFound = .FindNext(rFound) 

     Loop While Not rFound Is Nothing And rFound.Address <> firstAddress

如何擴展的代碼追加頭數據，以每個搜索結果是在其中標題是頁面下找到？

來源

2016-05-05 Lóránt Csaba Mihály

@DirkReichel，對不起，但「標題」就像每張紙上的標題，它包含nr，名稱，所有者和容量。我想在摘要頁面上的每個搜索結果後面粘貼這些內容。類似結果： 'Range（「G3：J3」）。複製表（「彙總」）。範圍（「O」＆lastRow）.PasteSpecial xlPasteValues' –

不會工作嗎？你的'Range（「G3：J3」）。複製表格（「Summary」）。範圍（「O」＆lastRow）.PasteSpecial xlPasteValues'對我來說看起來OK –

@DirkReichel nope，粘貼空白區域。在將rFound設置爲.FindNext之前，我在Do循環中插入了代碼 –

我嘗試了很多方法來選擇多個範圍並複製它們。一個範圍是一個變體，另一個範圍應該是靜態的。但它不起作用！爲什麼？

Private Sub cbGO_Click() 

    Dim ws As Worksheet, OutputWs As Worksheet 
    Dim rFound As Range, r1 As Range, r2 As Range, multiRange As Range 
    Dim strName As String 
    Dim count As Long, lastRow As Long 
    Dim IsValueFound As Boolean 

    IsValueFound = False 
    Set OutputWs = Worksheets("Summary") '---->change the sheet name as required 
    lastRow = OutputWs.Cells(Rows.count, "K").End(xlUp).Row 

    On Error Resume Next 
    strName = ComboBox1.Value 
    If strName = "" Then Exit Sub 
    For Each ws In Worksheets 

     If ws.Name <> "lists" And ws.Name <> "Summary" Then 

      With ws.UsedRange 

       Set rFound = .Find(What:=strName, LookIn:=xlValues, LookAt:=xlWhole) 
       If Not rFound Is Nothing Then 
        firstAddress = rFound.Address 

        'Range("G3:J3").Copy       -----> Ez a select header 
        'Sheets("Summary").Range("O" & lastRow + 1).PasteSpecial xlPasteValues 

        Do 

        IsValueFound = True 
        r1 = rFound.EntireRow.Cells(1, "B").Resize(1, 4) 
        r2 = Range("G3:J3") 
        Set multiRange = Union(r1, r2) 
        multiRange.Copy 
        OutputWs.Cells(lastRow + 1, 11).PasteSpecial xlPasteAll 
        Application.CutCopyMode = False 
        lastRow = lastRow + 1 
        Set rFound = .FindNext(rFound) 

        Loop While Not rFound Is Nothing And rFound.Address <> firstAddress 

       End If 
      End With 
     End If 
    Next ws 
    On Error GoTo 0 
    If IsValueFound Then 
     OutputWs.Select 
     MsgBox "Seach complete!" 

    Else 
     MsgBox "Name not found!" 
    End If 

End Sub

來源

2016-05-05 14:20:14

追加片頁眉/標題每個搜索結果

回答

相關問題