Excel VBA – 基于编号移动数据

我需要根据编号格式将数据从1 excel移动到另一个excel。 例如,我已经按照以下示例testing了test1 excel:

test1.xlsx

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

列以数字排列。 在这种情况下,我需要将数据移动到另一个excel中,并粘贴编号格式。

test.xlsx

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

每个由数字标识的列的值。 我如何做到这一点。 任何build议/参考非常感谢。 谢谢

 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 

这是没有testing,但从根本上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 

我不确定是否要重新排列行,或者如果示例只是用于说明的数字,但我假设您只是想根据标题行中的名称移动数据列。

我喜欢从Excel工作表中提取数据,并将数据放入数组中。 对数据做一些事情,然后把它放回到Excel工作表中。 这比在单元格中工作要快,在这种情况下它将工作得很好。 有关如何执行此操作的示例代码,请参阅http://www.cpearson.com/excel/ArraysAndRanges.aspx

您可以将每列放入其自己的数组中,然后使用位置(1,1)中的值重新排列目标文件中的值。 如果有不同的行包含订购信息,您可以调整该位置以满足您的需求。

尝试下面的代码。

它将“旧”工作表中的数据读入数组,将重新排列的数据写入新数组,然后将新数组的值分配给“新”工作表。

 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 

我把你的代码replaceFor ... 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