Транспонирование строк в столбцы, но я просто выбираю элементы, которые мне нужно транспонировать из набора данных

Question

Я пытаюсь манипулировать набором данных, перемещая определенные наборы данных из sheet1 к sheet2. У меня есть заголовок, состоящий из 16 элементов наsheets2, это все время одни и те же заголовки.

Я собираю данные и записываю их в sheet1. Они организованы в две колонки:

Столбец A: состоит из заголовков (по горизонтали, в строках - 57 элементов),

Столбец B: содержит значения для этих заголовков.

Теперь мне нужно выбрать заголовок из sheet2 и сопоставьте его с заголовком в sheet1, если совпадение найдено, скопируйте значения, смежные с этим заголовком, в sheet1и вставьте его под тем же заголовком в sheet2, в следующей доступной строке.

Для экономии места у меня есть частичный скриншот изsheet1 а также sheet2и у меня есть код VBA, который работает для первых 5 элементов, а затем завершается. У меня нет ошибок, я просто не передаю все 16 элементов вsheet2.

Sub headerLookup()

Dim ShtONE As Worksheet
Dim ShtTWO As Worksheet
Dim shtONEHead As Range 
Dim shtTWOHead As Range
Dim headerONE As Range 
Dim headerTWO As Range

Set ShtONE = Sheets("Sheet1")
Set ShtTWO = Sheets("Sheet2")


Dim lr As Long
Dim lc As Long
Dim lRow As Long

'get all of the headers in the first sheet, in Column 1(Horizantal) to get 57 rows

lr = ShtONE.Cells(Rows.Count, 1).End(xlUp).Row

Set shtONEHead = ShtONE.Range("A1", ShtONE.Cells(lr, 1))

'get all of the headers in second sheet, 16 columns
lc = ShtTWO.Cells(1, Columns.Count).End(xlToLeft).Column

Set shtTWOHead = ShtTWO.Range("A1", ShtTWO.Cells(1, lc))

'loop through Rows and find matching values on Columns then copy the value of the adjacent  cell and paste it on sheet2
For Each headerTWO In shtTWOHead
    For Each headerONE In shtONEHead
   
        If headerTWO.Value = headerONE.Value Then
        
            headerONE.Offset(0, 1).Copy
            headerTWO.Offset(1, 0).PasteSpecial xlPasteAll
            Application.CutCopyMode = False
          GoTo Next_headerTWO
        End If

        Next headerONE
        
Next_headerTWO:
Next headerTWO

   
End Sub

Answer 1

Хорошо, я думаю, это то, что ты хочешь. Если бы я делал это с нуля, я бы использовал функцию индекса, но, используя приведенный выше код, я отредактировал его, чтобы выполнить следующее. Пара исправлений:

1. Вы не ДОБАВЛЯЕТЕ свои данные, как вы, кажется, указываете "следующей доступной строкой". Вот почему вам, вероятно, понадобится VBA.
2. У вашего цикла необычный выход. Нет необходимости вставлять функции для такого небольшого набора данных, но если вы это сделаете, используйтеexit for.

В любом случае, вы можете протестировать этот образец, который я сделал.

Он включает следующий код:

Sub headerLookup()
Const firstSheetName As String = "Sheet1"
Const secondSheetName As String = "Sheet2"


'Define the sheets
Dim ShtONE As Worksheet, ShtTWO As Worksheet
    Set ShtONE = ThisWorkbook.Sheets(firstSheetName)
    Set ShtTWO = ThisWorkbook.Sheets(secondSheetName)

'get all of the headers in the first sheet, in Column 1(Horizantal) to get 57 rows
    Dim lr As Long, shtONEHead As Range
    lr = ShtONE.Cells(Rows.Count, 1).End(xlUp).Row
    Set shtONEHead = ShtONE.Range("A1", ShtONE.Cells(lr, 1))


'get all of the headers in second sheet, 16 columns
Dim lc As Long, shtTWOHead As Range
    lc = ShtTWO.Cells(1, Columns.Count).End(xlToLeft).Column
    Set shtTWOHead = ShtTWO.Range("A1", ShtTWO.Cells(1, lc))
    
'You need to identify the column to enter data.
Dim theInputRow As Long
    theInputRow = ShtTWO.Cells(Rows.Count, 1).End(xlUp).Row


'Loop through rows and columns (there are better ways to do this but adopting your range for illustration)
Dim headerONE As Range, headerTWO As Range
    For Each headerTWO In shtTWOHead.Cells
        For Each headerONE In shtONEHead.Cells
            If headerTWO.Value = headerONE.Value Then
                headerTWO.Offset(theInputRow, 0).Value = headerONE.Offset(0, 1).Value
                
                'you don't realy need to worry about performance, but if you do use EXIT FOR
                'Exit For
    
            End If
    
        Next headerONE
    Next headerTWO

End Sub

Answer 2

Дак,

Если я понимаю ваш вопрос, это должно сработать с помощью опции "Транспонировать" в меню "Вставить".

Sub CopyTranspose()

   Dim wksSht1 As Worksheet
   Dim wksSht2 As Worksheet
   Dim rngHdr  As Range
   Dim lMatch  As Long
   Dim lColCnt As Long
   
   Set wksSht1 = Worksheets("Sheet1")
   Set wksSht2 = Worksheets("Sheet2")
   lColCnt = 1
   Set rngHdr = wksSht2.Cells(1, lColCnt)
   
   Do
   
     lMatch = Application.Match(rngHdr.Value, wksSht1.Columns(1), 0)
     Range(wksSht1.Cells(lMatch, 1), wksSht1.Cells(lMatch, 1).End(xlToRight)).Copy
     rngHdr.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
                         SkipBlanks:=False, Transpose:=True
'*** Move to next Header column ***
     lColCnt = lColCnt + 1
     Set rngHdr = wksSht2.Cells(1, lColCnt)
        
   Loop While rngHdr <> ""
   
End Sub

Тестовый лист1:

Лист результатов 2: (начат только с заголовков столбцов в строке 1)

HTH