VBA複製/粘貼動態行，頻率取決於列數

Question

我是一個總VBA noob，並一直在努力尋找解決方案，我正在努力實現。我可以在網上找到這些作品，但似乎無法將它們串在一起。真的很感謝一些幫助！

我有以下格式的源文件：

 
+------------+------------+----------+--------+--------+ 
| From |  To  | Job Type | Apples | Orange | 
+------------+------------+----------+--------+--------+ 
| 08/01/2015 | 14/01/2015 | Bought |  1 |  2 | 
| 08/01/2015 | 14/01/2015 | Sold  |  3 |  4 | 
| 01/01/2015 | 07/01/2015 | Bought |  5 |  6 | 
| 01/01/2015 | 07/01/2015 | Sold  |  7 |  8 | 
+------------+------------+----------+--------+--------+ 

我需要一個宏把它轉換成以下格式上的另一個工作表：

 
+------------+------------+----------+---------+-------+ 
| From |  To  | Job Type | Product | Count | 
+------------+------------+----------+---------+-------+ 
| 08/01/2015 | 14/01/2015 | Bought | Apples |  1 | 
| 08/01/2015 | 14/01/2015 | Sold  | Apples |  3 | 
| 01/01/2015 | 07/01/2015 | Bought | Apples |  5 | 
| 01/01/2015 | 07/01/2015 | Sold  | Apples |  7 | 
| 08/01/2015 | 14/01/2015 | Bought | Oranges |  2 | 
| 08/01/2015 | 14/01/2015 | Sold  | Oranges |  4 | 
| 01/01/2015 | 07/01/2015 | Bought | Oranges |  6 | 
| 01/01/2015 | 07/01/2015 | Sold  | Oranges |  8 | 
+------------+------------+----------+---------+-------+ 

然而，行數，列是動態的，例如下週「香蕉」也可能作爲產品出現，並且或者可能有更多的日期行。

所以我試圖複製行的動態範圍與發生次數取決於列的數量。

我真的很希望這是有道理的。任何幫助將非常感激。

在此先感謝！

Answer 1

下面的代碼是否有訣竅？請注意，我推測原始數據位於名爲Original的工作表中，而擴展版本位於名爲Expanded的工作表中。我創建了非常具有描述性的變量名稱，以幫助我的代碼更易於遵循，但請發佈任何後續問題。

Sub MoveData() 
    Dim wsOriginal As Worksheet 
    Dim wsExpanded As Worksheet 
    Dim nLastRowExpanded As Long 
    Dim nLastRowOriginal As Long 
    Dim nSizeOfCopyRange As Long 

    ' Number of columns we are expanding 
    Const COLUMNS_TO_MOVE As Integer = 2 

    Set wsOriginal = Sheets("Original") 
    Set wsExpanded = Sheets("Expanded") 

    nLastRowOriginal = wsOriginal.Cells(Rows.Count, 1).End(xlUp).Row 
    nSizeOfCopyRange = nLastRowOriginal - 1 

    For i = 1 To COLUMNS_TO_MOVE 
     nLastRowExpanded = wsExpanded.Cells(Rows.Count, 1).End(xlUp).Row + 1 
     wsOriginal.Range("A2:C" & nLastRowOriginal).Copy wsExpanded.Range("A" & nLastRowExpanded) 
     wsExpanded.Range("D" & nLastRowExpanded).Value = wsOriginal.Cells(1, 3 + i).Value 
     wsExpanded.Range("D" & nLastRowExpanded).AutoFill Destination:=wsExpanded.Range("D" & nLastRowExpanded).Resize(nSizeOfCopyRange) 
     wsOriginal.Range("D2:D" & nLastRowOriginal).Offset(, i - 1).Copy wsExpanded.Range("E" & nLastRowExpanded) 
    Next i 

End Sub 

Answer 2

權，一些與上面的代碼（再次感謝，user3561813）修修補補之後，我知道了做什麼，我需要。可能有部分的下面是多餘的，但如果它不破...

我重視的行動稱爲「重組」

Private Sub Restructure_Click() 

Worksheets("Original").Activate 

Dim wsOriginal As Worksheet 
Dim wsExpanded As Worksheet 
Dim nLastRowExpanded As Long 
Dim nLastRowOriginal As Long 
Dim nSizeOfCopyRange As Long 
Dim lastColumn As Long 

Set wsOriginal = Sheets("Original") 
Set wsExpanded = Sheets("Expanded") 

lastColumn = Cells(1, Columns.Count).End(xlToLeft).Column 

Dim DATARANGE As Range 
Set DATARANGE = Range(Cells(1, 4), Cells(1, lastColumn)) 

nLastRowOriginal = wsOriginal.Cells(Rows.Count, 1).End(xlUp).row 
nSizeOfCopyRange = nLastRowOriginal - 1 

For i = 1 To DATARANGE.Count 

    nLastRowExpanded = wsExpanded.Cells(Rows.Count, 1).End(xlUp).row + 1 
    wsOriginal.Range("A2:C" & nLastRowOriginal).Copy wsExpanded.Range("A" & nLastRowExpanded) 
    wsExpanded.Range("D" & nLastRowExpanded).Value = wsOriginal.Cells(1, 3 + i).Value 
    wsExpanded.Range("D" & nLastRowExpanded).AutoFill Destination:=wsExpanded.Range("D" & nLastRowExpanded).Resize(nSizeOfCopyRange) 
    wsOriginal.Range("D2:D" & nLastRowOriginal).Offset(, i - 1).Copy wsExpanded.Range("E" & nLastRowExpanded) 
Next i 

End Sub