Excel VBA - 基於編號移動數據

Question

我需要根據編號格式將數據從1 excel移動到另一個excel。舉一個例子我已經樣品TEST1 Excel作爲每下面：

test1.xlsx

EName| Sal | ID | Tel | Add  | Depart  | Pos  | 
------------------------------------------------------------ 
John | 10000 | 123| NA | NY  | Finance | Manager | 
------------------------------------------------------------ 
    1 | 5 | 2 |  |   | 3  | 4  | 

列布置在數字。在這種情況下，我需要將我的數據移動到另一個excel test2並粘貼編號格式。

test.xlsx

Name | ID | Department | Level  |Position | Salary | 
    1 | 2 |  3  |   | 4  | 5 | 
John | 123| Fiinanace | NA  |Manager | 10000 | 

值用於由編號標識每一列。 我該如何做到這一點。任何建議/參考非常感謝。謝謝

Sub startGenerateExcel() 
Path1 = Range("F4").Value 
Path2 = Range("F6").Value 

Dim wbSource As Workbook 
Dim wbDest As Workbook 
Dim rngSource As Range 
Dim rngDest As Range 
Dim colNum As Integer 
Dim colDest As Integer 
Dim cl As Range 

Set wbSource = Workbooks(Path1) 
Set wbDest = Workbooks(Path2) 

Set rngSource = wbSource.Sheets("Sheet1").Range("A1:G3") 'Modify as needed 
Set rngDest = wbDest.Sheets("Sheet1").Range("A1:F3") 'Modify as needed 

For Each cl In rngSource.Rows(2) 
    colNum = cl.Offset(1, 0).Value 
    colDest = Application.Match(colNum, rngDest.Rows(3), False) 
    rngDest.Cells(2, colDest).Value = cl.Value 
Next 
End Sub 

Answer 1

這是沒有測試，但從根本上shoudl的工作。我一直使用Match函數來做這種事情。你將不得不調整它爲特定目的，即，假設你的表是不是僅僅3行以上，等

Sub TransferValuesUsingMatch() 

Dim wbSource as Workbook 
Dim wbDest as Workbook 
Dim rngSource as Range 
Dim rngDest as Range 
Dim colNum as Integer 
Dim colDest as Integer 
Dim cl as Range 

Set wbSource = Workbooks("test1.xlsx") 'Assumes the workbook is already open 
Set wbDest = Workbooks("test.xlsx") 'Assumes the workbook is already open 
Set rngSource = wbSource.Sheets("Sheet1").Range("A1:G3") 'Modify as needed 
Set rngDest = wbDest.Sheets("Sheet1").Range("A1:F3") 'Modify as needed 

For each cl in rngSource.Rows(2) 
    colNum = cl.Offset(1,0).Value 
    colDest = Application.Match(colNum, rngDest.Rows(3), False) 
    rngDest.Cells(2,colDest).Value = cl.Value 
Next 

End Sub 

Answer 2

我不知道，如果你想重新排列行過，或者如果你只是例子有數字用於說明，但我假設您只是想根據標題行中的名稱移動數據列。

我喜歡從Excel工作表中提取數據並將數據放入數組中。對數據做些什麼，然後將其放回Excel表格中。它比在單元格中工作更快，在這種情況下它將很好地工作。有關如何執行此操作的一些示例代碼，請參閱http://www.cpearson.com/excel/ArraysAndRanges.aspx。

可以將每列放入其自己的數組中，然後使用位置（1,1）中的值重新排列目標文件中的值。如果有不同的行包含訂購信息，您可以調整該位置以滿足您的需求。

Answer 3

請嘗試下面的代碼。

它將「舊」工作表中的數據讀入數組，將重新排列的數據寫入新數組，然後將新數組的值分配給「新」工作表。

Sub CopyAndRearrange() 

    Dim oldWkb As Workbook, newWkb As Workbook 
    Dim oldRange As Range, newRange As Range 
    Dim oldArr(), newArr() 

    'Assume data are in Sheet1 in oldWkb and need to go to Sheet1 in newWkb 
    'and that both workbooks are open 
    Set oldWkb = Workbooks("aWkb.xlsm") 
    Set newWkb = Workbooks("anotherWkb.xlsm") 
    Set oldRange = oldWkb.Worksheets(1).Range("A2:G11") 
    Set newRange = newWkb.Worksheets(1).Range("A2:F11") 
    Dim i As Long, j As Long 

' Assume data have fixed, known dimensions 
    ReDim oldArray(1 To 10, 1 To 7) 
    oldArray = oldRange 
    ReDim newArray(1 To 10, 1 To 6) 
    For i = 1 To 10 
     For j = 1 To 6 
      Select Case j 
       Case 1 
        newArray(i, 1) = oldArray(i, 1) '1->1 
       Case 2 
        newArray(i, 6) = oldArray(i, 2) '2->6 
        Debug.Print newArray(i, 6) 
       Case 3 
        newArray(i, 2) = oldArray(i, 3) '3->2      
       Case 4 
        newArray(i, 3) = oldArray(i, j + 2) '6->3 
       Case 5 
        newArray(i, 5) = oldArray(i, j + 2) '7->5 
       Case 6 
        newArray(i, 4) = "NA"    'NA->4 
      End Select 
     Next j 
    Next i 
    newRange.Value = newArray 

End Sub 

Answer 4

我你的代碼，替換For ... Next有：

For Each cl In rngSource.Rows 'Handle whole row at once! 
    rngDest.Cells(cl.Row, 1).Resize(, 6) = Array(cl.Cells(, 1), cl.Cells(1, 3), cl.Cells(1, 6), Empty, cl.Cells(1, 7), cl.Cells(1, 2)) 
Next