需要使用VBA转换Excel单元格值

Question

我有一个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

使用数组的替代方法（请注意，这甚至不是最好的方法，只是替代方法 -更欢迎提出更正和建议）：

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秒内处理200,000条记录。