宏將x列中的數據重新排列爲x行，然後複製A行和B行中的數據

我在電子表格中排列的數據量相當大。目前的格式有一個公司，一個產品名稱，以及之後列出的成分。成分都有自己的列沒有標題。舉例來說，我很抱歉，這是不低於體現，因爲我在標記語言可怕，列A將被標記廠商，列B將被標記爲產品名稱，C欄將被標註成分但隨後其餘的列沒有標籤。宏將x列中的數據重新排列爲x行，然後複製A行和B行中的數據

最終，我需要將數據移動到一個新的工作表，其中數據只出現在A，B和C列中。每個產品的成分數量都有所不同。

我希望所需的格式有幫助。

當前格式：

1| Acme Inc. | ABC123  | Water  | Sugar  | Eggs | Salt 
2| Acme Inc. | BCD456  | Cornmeal | Salt 
3| JJ Baking | JJ4567  | Flour  | Nuts  | Fruit

所需的格式：

1| Acme Inc. | ABC123 | Water 
2| Acme Inc. | ABC123 | Sugar 
3| Acme Inc. | ABC123 | Eggs 
4| Acme Inc. | ABC123 | Salt 
5| Acme Inc. | BCD456 | Cornmeal 
6| Acme Inc. | BCD456 | Salt 
7| JJ Baking | JJ4567 | Flour 
8| JJ Baking | JJ4567 | Nuts 
9| JJ Baking | JJ4567 | Fruit

來源

2015-11-04 user3490381

這應該做的伎倆，我把我的許多假設代碼中的註釋。

我的主要問題是，列與數據之間沒有差距。 EG：填寫D欄，E欄空白，填寫F欄。

此外，對於列A的條目沒有「空白」行，並且當我們看到空白行時，函數停止。請填寫您的「工作表名稱」，在其中寫明「自定義爲您的工作表名稱」。

Public Sub ReOrder() 
    Dim sheet As Worksheet 
    Dim row As Integer 
    Dim col As Integer 
    Dim offset As Integer 
    row = 2 

    'Customize to your sheet name 
    Set sheet = ThisWorkbook.Worksheets("Sheet1") 

    'I am assuming there are no 'blanks' between rows or columns 
    'If there are such 'blanks' use UsedRange.Rows or UsedRange.Columns 
    'Then skip over the blanks with an if statement 

    'Keep processing while we see data in the first column 
    While (sheet.Cells(row, 1).Value <> "") 
     'We only need to make a new row if anything past column C is filled out with something 
     col = 4 
     offset = 1 
     While (sheet.Cells(row, col).Value <> "") 
      'Insert new row 
      sheet.Rows(row + offset).EntireRow.Insert shift:=xlDown 

      'Assign Column values to the new row 
      sheet.Cells(row + offset, 1).Value = sheet.Cells(row, 1).Value 
      sheet.Cells(row + offset, 2).Value = sheet.Cells(row, 2).Value 
      sheet.Cells(row + offset, 3).Value = sheet.Cells(row, col).Value 

      'Remove Column value from the source row 
      sheet.Cells(row, col).Value = "" 

      col = col + 1 
      offset = offset + 1 
     Wend 
     row = row + 1 
    Wend 
End Sub

來源

2015-11-04 17:31:19

謝謝您的答覆，這兩個宏工作爲了我想要做的！ – user3490381

這裏是一個短，應該工作：

Sub test() 
Dim lastRow&, lastCol&, noItems& 
Dim i&, k& 
' This macro will assume your column A and B are constant, and your items will start in column C 
lastRow = Cells(Rows.Count, 1).End(xlUp).Row 

For i = lastRow To 1 Step -1 
    lastCol = Cells(i, Columns.Count).End(xlToLeft).Column 
    noItems = WorksheetFunction.CountA(Range(Cells(i, 3), Cells(i, lastCol))) 

    ' Now we know how many items, so add the info to the new rows. 
    ' Start with the name and col B 
    Range(Cells(i + 1, 1), Cells(i + noItems - 1, 1)).EntireRow.Insert 
    Range(Cells(i, 1), Cells(i + noItems - 1, 2)).FillDown 
    For k = 1 To noItems - 1 
     Cells(i + k, 3).Value = Cells(i, 3 + k).Value 
     Cells(i, 3 + k).Value = "" 
    Next k 

Next i 

End Sub

它看起來列C通過[該行中的任何列是最後一個，去右]，然後創建新行以適應那裏的物品數量。

來源

2015-11-04 17:35:06 BruceWayne

非常感謝！這幫了大忙！ – user3490381

@ user3490381 - 如果它適合你，你介意標記爲答案嗎？（或者如果克里斯更好，標記他）。如果您需要任何調整，請讓我知道！ – BruceWayne

我猜3a3n代碼是公司特定的。假設ABC1231位於Sheet1的B1中，插入一個新的Row1並應用詳細的技術here，選擇「步驟2b的3」中的範圍爲B1：到數據的末尾。當您進入表格時，您可以進行過濾以選擇並刪除列Value中的空白行。

在B2中輸入：

=INDEX(Sheet3!A:A,MATCH(A4,Sheet3!B:B,0))

選擇和複製表，然後粘貼...，價值過頂，並切換列A的順序和B.

來源

2015-11-04 18:41:01 pnuts

宏將x列中的數據重新排列爲x行，然後複製A行和B行中的數據

回答

相關問題