Transposing rows into columns, but I am just picking the elements that I need to transpose from a set of data

问题

I am trying to manipulate a set of data by moving certain data sets from sheet1 to sheet2. I have a header consisting of 16 elements on sheets2, they are same headers all the time.

I collect data and write them in sheet1. They are organized in two columns:

Column A: consists of the headers(Horizontal, in rows- 57 elements),

Column B: consists of the values for these headers.

Now, I need to pick a header from sheet2 and match it to a header in sheet1, if a match is found, then copy the values adjacent to that Header, in sheet1, and paste it under the same header in sheet2, on the next available row.

To save space I have a partial screenshot of sheet1 and sheet2 and I have a VBA code that works for the first 5 elements and then terminates. I don’t get any errors I just don’t get all the 16 elements transferred to 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

回答1:

Okay, I think this does what you want. If I were doing this from scratch, I'd use an index fucntion, but using your above code, I've edited it to accomplish the following. A couple corrections:

You are not APPENDING your data, which is what you seem to state by "next available line". This is why you probably need VBA.
Your loop has an unusual exit. No need to insert functionality for such a small set of data, but if you do, use exit for.

Anyway, you can test with this sample sheet I made.

It includes the following code:

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

回答2:

Dak,

If I understand your question this should do the trick using the Transpose option of 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

来源：https://stackoverflow.com/questions/62888752/transposing-rows-into-columns-but-i-am-just-picking-the-elements-that-i-need-to

标签

excel

vba