Fetch данные по горизонтали

Question

Это простой пример исходного состояния Лист1:

| A | B | C | D | E | 
1| 101| 102| 103| 104| 105| 
2|  |  |  |  |  | 
3|  |  |  |  |  | 

Это простой пример данных в Лист2:

| A | B | C | D | E | F | G | 
1|Name1 |Name2 |Name3 |Name4 |Name5 |Name6 |Name7 | 
2|101abc|106abc|107abc|104zyx|106def|102abc|101def| 
3|106ghi|102def|104wvu|101ghi|107def|105zyx|104tsr| 
4|101jkl|102ghi|101mno|101pqr|104qpo|106jkl|102jkl| 
5|102mno|102pqr|104nml|106mno|101stu|104kji|102stu| 

Я пытаюсь написать макрос, который будет извлекать данные из Лист2 и добавить его в Лист1 создать:

| A | B | C | D | E | 
1| 101| 102| 103| 104| 105| 
2|101abc|102abc|  |104zyx|105zyx| 
3|101def|102def|  |104wvu|  | 
4|101ghi|102ghi|  |104tsr|  | 
5|101jkl|102jkl|  |104qpo|  | 
6|101mno|102mno|  |104nml|  | 
7|101pqr|102pqr|  |104kji|  | 
8|101stu|102stu|  |  |  | 

Ряд 1 листа1 содержит ключевые слова, идентифицирующие ва я хочу извлечь.

Строка 1 листа 2 содержит заголовки, которые не имеют отношения к текущему макросу. Остальные строки содержат значения, начинающиеся с ключевых слов. Я пытаюсь извлечь значения из Sheet2, которые соответствуют каждому ключевому слову в Sheet1, и перечислить их по ключевому слову.

Было бы здорово, если бы кто-нибудь помог мне в этом.

Answer 1

Я переписал ваш вопрос из ваших комментариев, так как важно, чтобы вопрос был ясен и соответствует ответу. Пожалуйста, убедитесь, что любой будущий вопрос ясен, когда вы публикуете его; не полагайтесь на тех, кто хочет дразнить требование из вас.

Option Explicit 
Sub Report() 

    ' Introduction to Version 1 

    ' * I have set row 1 of Sheet1 to 101, 102, 103, 104 and 105 
    ' * I have scattered the values 101, 102, 104 and 105 across Sheet2 
    ' starting from cell A2. 
    ' * For each value in row 1 of Sheet1, this macro either: 
    ' * Reports it cannot find the value in Sheet2. 
    ' * Lists the addresses of the cells containing the values. 
    ' * I do not understand what you want to do when you discover cell XN 
    ' contains a value from row 1 of Sheet1 so I have stored the addresses 
    ' in a collection. You may wish to keep the collection so you can 
    ' process all the occurrences of a value at the same time (as I do) 
    ' or you may discard the collection and process each value as you find 
    ' it. 

    ' Introduction to Version 2 which was created from version 1 after clarification 
    ' of the contents of Sheet2 and clairification of the required output. 

    ' * The appearances of Sheet1 and Sheet2 are now as shown in the question. 
    ' * The values found (rather than the addresses) are now stored in the 
    ' collection. 
    ' * At the end of each repeat of the inner loop, the values found are now 
    ' written to Sheet1 under the appropriate header 

    Dim ColSht1Crnt As Long 
    Dim InxL As Long 
    Dim Locations As New Collection 
    Dim RngFirst As Range 
    Dim RngCrnt As Range 
    Dim RowSht1Crnt As Long 
    Dim SearchValue As String 
    Dim Wsht1 As Worksheet 
    Dim Wsht2 As Worksheet 

    Set Wsht1 = Worksheets("Sheet1") 
    Set Wsht2 = Worksheets("Sheet2") 

    ' Clear any data in Sheet1 stored by a previous run of this macro 
    Wsht1.Rows("2:" & Rows.Count).Delete 

    ColSht1Crnt = 1 

    ' Each repeat of this outer loop processing a column of Sheet1. It 
    ' finishes when it finds an empty column in row 1. 
    Do While Wsht1.Cells(1, ColSht1Crnt).Value <> "" 

    SearchValue = Wsht1.Cells(1, ColSht1Crnt).Value 

    With Wsht2 

     ' The value for After means the first cell examined is A2. The values for 
     ' SearchOrder and SearchDirection means the search down the sheet from left 
     ' to right. 
     ' V1 Search for SearchValue. V2 Search for anything starting with SearchValue 
     Set RngFirst = .Cells.Find(What:=SearchValue & "*", After:=.Cells(1, Columns.Count), _ 
           LookAt:=xlWhole, SearchOrder:=xlByRows, _ 
           SearchDirection:=xlNext) 

     If RngFirst Is Nothing Then 
     'Debug.Print "There are no occurrences of [" & SearchValue & "]" & " in Sheet2" 
     Else 
     ' There is at least one occurence of SearchValue 

     ' V1 Delete any locations recorded for the last SearchValue 
     ' V2 Delete any values recorded for the last SearchValue 
     Do While Locations.Count > 0 
      Locations.Remove (1) 
     Loop 

     Set RngCrnt = RngFirst 

     ' V1 Each repeat of this loop records the location of an occurrence of SearchValue 
     ' V2 Each repeat of this loop records a value found that starts with SearchValue 
     Do While True 

      ' V1 Record location of SearchValue 
      'Locations.Add (Replace(RngCrnt.Address, "$", "")) 
      ' V2 Record value of cell starting SearchValue 
      Locations.Add (RngCrnt.Value) 

      Set RngCrnt = .Cells.FindNext(After:=RngCrnt) 

      If RngCrnt.Address = RngFirst.Address Then 
      ' Search has looped and has found first occurrence again 
      Exit Do 
      End If 

     Loop 

     ' V1 Debug.Print "[" & SearchValue & "]" & " has been found in Sheet2 in the following cells:"; 
     ' V1 For InxL = 1 To Locations.Count 
     ' V1 Debug.Print " " & Locations(InxL); 
     ' V1 Next 
     ' V1 Debug.Print 
     ' V2 Store values found under heading 
     RowSht1Crnt = 2 
     With Wsht1 
      For InxL = 1 To Locations.Count 
      .Cells(RowSht1Crnt, ColSht1Crnt).Value = Locations(InxL) 
      RowSht1Crnt = RowSht1Crnt + 1 
      Next 
     End With 

     End If 

    End With 

    ColSht1Crnt = ColSht1Crnt + 1 
    Loop 

End Sub