需要使用VBA来移动Excel单元格值

我有一个Excel表格，数据被SQL填充。 作为后处理的一部分，我需要格式化电子表格如下。

原始数据：

**Emp ID** **Last Name** **First Name** **Department** **Title** **Office** 1234 Stewart John Finance Analyst Office1 5678 Malone Rick Marketing Analyst Office 2 3456 Wresely Eric HR Recuriter Office 3 

格式化数据

 **Emp ID** **Last Name** **First Name** 1234 Stewart John **Department** **Title** **Office** Finance Analyst Office1 **Emp ID** **Last Name** **First Name** 5678 Malone Rick **Department** **Title** **Office** Marketing Analyst Office 2 **Emp ID** **Last Name** **First Name** 3456 Wresely Eric **Department** **Title** **Office** HR Recuriter Office 3 

任何关于如何通过VBA来实现这一点的帮助都是很棒的

Answer 1

您可以遍历数据，复制值并将其写入新的工作表

 Sub CopyValues() Sheets(1).Activate For curRow = 2 To 20 EmpId = Cells(curRow, 1).Value lastName = Cells(curRow, 2).Value firstName = Cells(curRow, 3).Value department = Cells(curRow, 4).Value Title = Cells(curRow, 5).Value ' write them to sheet 2 Sheets(2).Cells(4 * curRow, 1).Value = "**Emp ID** " Sheets(2).Cells(4 * curRow, 2).Value = "**First Name**" Sheets(2).Cells(4 * curRow, 3).Value = "**Last Name**" Sheets(2).Cells(4 * curRow + 1, 1).Value = EmpId Sheets(2).Cells(4 * curRow + 1, 2).Value = firstName Sheets(2).Cells(4 * curRow + 1, 3).Value = lastName Sheets(2).Cells(4 * curRow + 2, 2).Value = "**Department**" Sheets(2).Cells(4 * curRow + 3, 2).Value = department Sheets(2).Cells(4 * curRow + 2, 3).Value = "**Title**" Sheets(2).Cells(4 * curRow + 3, 3).Value = Title Next Sheets(2).Activate End Sub 

你应该可以根据需要调整其余部分，试试看，并随时随地玩耍。

这是上面的代码的结果。

Answer 2

使用数组的替代方法（请注意，这甚至不是最好的方法，只是一个替代方法 – 更正和build议更受欢迎）：

 Sub BulletHell() Start = Timer() Dim WS0 As Worksheet, WS1 As Worksheet Dim EmpDetailsOne As Variant, EmpDetailsTwo As Variant Dim HeadOne() As Variant, HeadTwo() As Variant Dim RngTarget As Range, NumOfEmp As Long, aIter As Long With ThisWorkbook Set WS0 = .Sheets("Sheet1") 'Modify as necessary. Set WS1 = .Sheets("Sheet2") 'Modify as necessary. End With EmpDetailsOne = WS0.Range("A2:C101").Value 'Modify as necessary. EmpDetailsTwo = WS0.Range("D2:F101").Value 'Modify as necessary. HeadOne = Array("EmpID", "LastName", "FirstName") HeadTwo = Array("", "Department", "Title", "Office") Set RngTarget = WS1.Range("A1") NumOfEmp = UBound(EmpDetailsOne) For aIter = 1 To NumOfEmp With RngTarget .Resize(1, 3).Value = HeadOne .Offset(1, 0).Resize(1, 3).Value = Array(EmpDetailsOne(aIter, 1), EmpDetailsOne(aIter, 2), EmpDetailsOne(aIter, 3)) .Offset(2, 0).Resize(1, 4).Value = HeadTwo .Offset(3, 1).Resize(1, 3).Value = Array(EmpDetailsTwo(aIter, 1), EmpDetailsTwo(aIter, 2), EmpDetailsTwo(aIter, 3)) End With Set RngTarget = RngTarget.Offset(4, 0) Next aIter Debug.Print Timer() - Start End Sub 

没有任何节省时间的“技巧”，这可以在20秒内处理20万条logging。