以不同的列顺序从行中复制数据

Question

我需要将数据行从一个工作表复制到另一个工作表。但我必须更改列的顺序。例如来自A,B,C 列E,L,J 中的数据等等。我已经研究了一个解决方案，下面的代码希望能显示我想要做什么。

有没有更简洁的方法来复制数据？我的版本在执行时很慢。 如何在没有空行的情况下复制target worksheet 中的数据？

Sub KopieZeilenUmkehren()
    Dim Zeile As Long
    Dim ZeileMax As Long
    Dim n As Long

    With Sheets("Artikel")
        ZeileMax = .UsedRange.Rows.Count
        n = 1

        For Zeile = 2 To ZeileMax

            If .Cells(Zeile, 1).Value = "Ja" Then

                .Range("A" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("E" & Zeile)
                .Range("B" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("L" & Zeile)
                .Range("C" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("J" & Zeile)
                .Range("D" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("I" & Zeile)
                .Range("E" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("H" & Zeile)
                .Range("F" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("G" & Zeile)
                .Range("G" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("F" & Zeile)
                .Range("H" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("A" & Zeile)
                .Range("I" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("D" & Zeile)
                .Range("J" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("C" & Zeile)
                .Range("K" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("B" & Zeile)
                .Range("L" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("K" & Zeile)

                n = n + 1

            End If
        Next Zeile
    End With
End Sub

Answer 1

更改列顺序并过滤行

我的版本在执行时很慢。

通过 VBA 循环遍历整个范围非常耗时，您可以加快将范围数据分配给变量数组v - c.f. 的过程。 [1] 部分。

    v = rng

使用Application.Index 函数的高级可能性，可以重新组织整个数组结构，包括单元格值的行过滤（例如"Ja"） - c.f. [2] 部分。

    v = Application.Index(v, getRowNums(v, "Ja"), getColNums())

...并仅通过一行代码将其写入任何给定目标（参见 [3] 部分）。

    ThisWorkbook.Worksheets("ArtikelNeu").Range("A1").Resize(UBound(v), UBound(v, 2)) = v

调用示例

Sub Restructure()
' Purpose: restructure range columns
  With ThisWorkbook.Worksheets("Artikel")                                              ' worksheet referenced e.g. via CodeName

    ' [0] identify range
      Dim rng As Range, lastRow&, lastCol&
      lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row            ' get last row and last column
      lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
      Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))  ' define data range
    ' ~~~~~~~~~~~~
    ' [1] get data
    ' ~~~~~~~~~~~~
      Dim v: v = rng                                            ' assign to 1-based 2-dim datafield array
      Debug.Print rng.Address, "v(" & UBound(v) & "," & UBound(v, 2) & ")"

    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' [2] restructure column order in array in a one liner
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      v = Application.Index(v, getRowNums(v, "Ja"), getColNums())

  End With
' [3] write restructured data to target sheet
      With ThisWorkbook.Worksheets("ArtikelNeu")
          .Cells.Clear
          .Range("A1").Resize(UBound(v), UBound(v, 2)) = v      ' write new data
      End With

End Sub

需要的辅助函数

这两个函数只返回一个找到的行号数组以及一个新列号的数组。

Private Function getRowNums(data, ByVal search As String) As Variant()
' Purpose: return array of row numbers (including title row)
'          where cell in column A equals search criteria "Ja"
  Dim i&, ii&                     ' row counters
  ReDim tmp(1 To UBound(data))    ' temporary array
  ii = 1: tmp(ii) = 1             ' get title row (no 1) in any case
  For i = 2 To UBound(data)       ' check each row in first column (A)
      If LCase(data(i, 1)) = LCase(search) Then ii = ii + 1: tmp(ii) = i
  Next i
  ReDim Preserve tmp(1 To ii)     ' reduce total items to title row + findings
  Debug.Print "getRowNums = Array(" & Join(tmp, ",") & ")"      ' e.g. Array(1,2,4, ...)
  getRowNums = Application.Transpose(tmp)
End Function

Private Function getColNums() As Variant()
' Purpose: return array of new column number order, e.g. Array(5,12,10,9,8,7,6,1,4,3,2,11) based on columns E, L, J etc.
  Const NEWORDER = "E,L,J,I,H,G,F,A,D,C,B,K"  ' << change to wanted column order
  Dim i&, items: items = Split(NEWORDER, ",")
  ReDim tmp(1 To UBound(items) + 1)
' fill 1-based temporary array with col numbers (retrieved from letters A,B,C...
  For i = 0 To UBound(items)
      tmp(i + 1) = Range(items(i) & ":" & items(i)).Column
  Next i
    Debug.Print "getColNums = Array(" & Join(tmp, ",") & ")"    ' e.g. 5|12|10|9|8|7|6|1|4|3|2|11
  getColNums = tmp           ' return array with new column numbers (1-based)
End Function

给 OP 的提示

如何在没有空行的情况下复制目标工作表中的数据？

使用计数器n 更改原始帖子中的代码允许忽略空行。而不是例如.Range("A" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("E" & Zeile)应该是

    .Range("A" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("E" & n)

在上面的示例调用中，过滤由函数 getRowNums(v,"Ja") 执行。

推荐链接

您可以在 Insert first column in datafield array without loops or API calls 找到 Application.Index 函数的一些特殊之处