Изменить порядок столбцов и отфильтровать строки
Моя версия работает довольно медленно при выполнении.
Цикл поВесь диапазон с помощью VBA занимает много времени, вы ускоряете процесс назначения данных диапазона для массива вариантов v - ср. сечение [1].
v = rng
Используя расширенные возможности функции Application.Index, можно реорганизовать всю структуру массива, включая фильтрацию строк для значений ячеек (например, "Ja") - см. Раздел [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").
Рекомендуемая ссылка
Вы можете найти некоторые особенности функции Application.Index в Вставить первый столбец в массив полей данных без циклов или вызовов API