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

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

Dak,

Если я понимаю ваш вопрос, это должно сработать с использованием опции «Транспонировать» в Paste.

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

Test sheet1:

Result sheet2: (started with only column headers in row 1)

Лист результатов

HTH

Answer 2

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

1. Вы не ДОБАВЛЕНИЕ ваших данных, что вы, кажется, указываете "следующей доступной строкой". Вот почему вам, вероятно, понадобится VBA.
2. Ваш l oop имеет необычный выход. Нет необходимости вставлять функциональность для такого небольшого набора данных, но если вы это сделаете, используйте 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