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

提示操作

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

使用计数器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函数的一些特色

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

1 个答案: