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

这没有经过测试，但基本上应该可以工作。我一直使用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