需要使用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條記錄。