Copy data from rows in different column order

问题

I need to copy rows of data from one worksheet to another. But i have to change the order of the columns. For example Data from A,B,C in columns E,L,J and so on. I already worked on a solution and the code below hopefully shows what i want to do.

Is there a cleaner way to copy the data? My version is quite slow while executing. How can i copy the data in the target worksheet without empty rows?

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

回答1:

Change column order and filter rows

My version is quite slow while executing.

Looping through a whole range by means of VBA is time consuming, you speed up the process assigning range data to a variant array v - c.f. section [1].

    v = rng

Using the advanced possibilities of the Application.Index function it's possible to reorganize the entire array structure including row filtering for cell values (e.g. "Ja") - c.f. section [2].

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

... and write it to any given target (c.f. section [3]) by only one code line.

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

Example call

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

Needed helper functions

These two functions simply return an array of found row numbers as well as an array of the new column numbers.

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

Hint to OP

How can I copy the data in the target worksheet without empty rows?

Changing code in original post using counter n allows to ignore empty rows. Instead of e.g. .Range("A" & Zeile).Copy Destination:=Worksheets("ArtikelNeu").Range("E" & Zeile) it should be

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

In the example call above the filtering is executed by function getRowNums(v,"Ja").

Recommended link

You find some pecularities of the Application.Index function at Insert first column in datafield array without loops or API calls

来源：https://stackoverflow.com/questions/56817021/copy-data-from-rows-in-different-column-order