需要使用VBA移動Excel單元格值

我有一個Excel表格，其中數據由SQL填充。作爲後處理的一部分，我需要按如下格式設置電子表格。需要使用VBA移動Excel單元格值

原始數據：

**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做到這一點任何幫助將是巨大的

來源

2014-02-25 user3324344

僅僅意味着部門/職位和辦公室應該在下一行？ – Trace

是的，對於每個emp id，需要將部門，標題和辦公室移動到行，並且需要保留標題 – user3324344

謝謝。現在我有小數據集來測試，它工作正常。 – user3324344

您可以通過數據循環，複製值和將它們寫入新工作表

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

您應該可以根據自己的需要調整其餘部分，方法是嘗試一下，然後玩弄它。

這是上面的代碼的結果。

Output of code above

來源

2014-02-25 14:31:30 surfmuggle

根據數據量，此代碼可能運行速度非常慢。 – Trace

您可以關閉屏幕更新，並且如果這不足以處理範圍。但我已經複製了數百行這種方式，並沒有遇到問題。如果你不介意這個宏需要幾分鐘的時間。在我提到的旁邊有沒有其他的選擇？ – surfmuggle

我不是說這是錯的。一般來說，建議獲得最佳性能的方法是將數據加載到內存中（例如，從記錄集到數組），將數組大小調整爲範圍的維數，並使用單個寫入操作'oRange = vArray' 。目前，您將對每個項目執行寫入操作。對於數量有限的記錄，我想它不會受到傷害。 – Trace

其他陣列使用方法（注意，這甚至都不是最佳的解決辦法，只是一個替代一個 - 改正和建議多於歡迎）：

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條記錄。

來源

2014-02-25 17:13:31 Manhattan

需要使用VBA移動Excel單元格值

回答

相關問題