需要使用 VBA 移动 excel 单元格值答案

【问题标题】：Need to shift excel cell values using VBA需要使用 VBA 移动 excel 单元格值
【发布时间】：2014-02-26 01:13:31
【问题描述】：

我有一个 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 完成此任务的帮助都会很棒

【问题讨论】：

仅仅意味着部门/职务和办公室应该在下一行？
是的，对于每个emp id，需要将部门、职称和办公室移动到行，并且需要保留标题
谢谢。现在我有小数据集要测试，它工作正常。

标签： vba excel

【解决方案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

您应该能够通过尝试和使用它来根据需要调整其余部分。

这是上面代码的结果。

【讨论】：

根据数据量，这段代码运行速度可能会很慢。
您可以关闭屏幕更新，如果这还不够，请使用范围。但是我以这种方式复制了数百行并且没有遇到问题。如果您不介意宏需要几分钟。除了我提到的那些，你还有其他选择吗？
我并不是说这是错的。通常，获得最佳性能的推荐方法是将数据加载到内存中（例如，从记录集到数组），将数组大小调整为范围的尺寸，然后使用单个写入操作oRange = vArray 呈现数组。目前，您将对每个项目执行写入操作。对于有限数量的记录，我想它不会受到伤害。
+1：在这方面，@KimGysen 是正确的。最多大约一万条记录，这将需要几秒钟。但是，一旦它达到 100,000 或 200,000 条记录，这与数组方法之间的区别就会清楚地显示出来。但是，正如 OP 所说的数据集很小，一切都很好。 :)

【解决方案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 条记录。

【讨论】：