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