Change data in vertical table to individual rows using VBA

问题

I have an Excel workbook with the following format:

  | A  | B     | C     | D     | E     |   
  |----|-------|-------|-------|-------|  
 1|    | po#1  | po#2  | po#3  | po#1  |
 2|    | date1 | date2 | date3 | date4 |
 3|sku1| qty1  | qty4  | qty7  | qty10 | 
 4|sku2| qty2  | qty5  | qty8  | qty11 |
 5|sku3| qty3  | qty6  | qty9  | qty12 |

that I need to convert to the following format:

  | A      | B     | C     | D     |
  |--------|-------|-------|-------|
 1|  po#1  | date1 | sku1  | qty1  |
 2|  po#1  | date1 | sku2  | qty2  |
 3|  po#1  | date1 | sku3  | qty3  |
 4|  po#1  | date4 | sku1  | qty10 |
 5|  po#1  | date4 | sku2  | qty11 |
 6|  po#1  | date4 | sku3  | qty12 |
 7|  po#2  | date2 | sku1  | qty4  |
 8|  po#2  | date2 | sku2  | qty5  |
 9|  po#2  | date2 | sku3  | qty6  |
10|  po#3  | date3 | sku1  | qty7  |
11|  po#3  | date3 | sku2  | qty8  |
12|  po#3  | date3 | sku3  | qty9  |

using VBA.

回答1:

If your headers are all contained in rows 1:2 and column A:A, then you could use this code:

Dim sht1 As Worksheet, sht2 As Worksheet
Dim cel As Range
Dim rowWrite As Long

rowWrite = 1
Set sht1 = ActiveSheet
Set sht2 = ActiveWorkbook.Worksheets.Add
For Each cel In sht1.Range("B3", sht1.Range("B2").End(xlToRight).End(xlDown).Address)
    With sht2.Range("A" & rowWrite)
        .Offset(, 0).Value = cel.EntireColumn.Resize(1).Value
        .Offset(, 1).Value = cel.EntireColumn.Resize(1).Offset(1).Value
        .Offset(, 2).Value = cel.EntireRow.Resize(1).Value
        .Offset(, 3).Value = cel.Value
    End With
    rowWrite = rowWrite + 1
Next cel

This will create a new worksheet and write your data to that. It won't preserve formatting, let me know if you need that.

Hope this helps.

来源：https://stackoverflow.com/questions/33532185/change-data-in-vertical-table-to-individual-rows-using-vba

标签

excel

excel-vba

vba