excel - 以不同的列顺序从行中复制数据
问题描述
我需要将数据行从一个工作表复制到另一个工作表。但我必须更改列的顺序。例如来自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
解决方案
更改列顺序和过滤行
我的版本在执行时很慢。
通过 VBA 循环遍历整个范围非常耗时,您可以加快将范围数据分配给变量数组的过程v
- cf 部分[1]
。
v = rng
使用该Application.Index
功能的高级可能性,可以重新组织整个数组结构,包括单元格值的行过滤(例如"Ja"
)-cf section [2]
。
v = Application.Index(v, getRowNums(v, "Ja"), getColNums())
...并仅通过一个代码行将其写入任何给定目标(cf section [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)
在上面的示例调用中,过滤由 function 执行getRowNums(v,"Ja")
。
推荐链接
您可以在没有循环或 API 调用的情况下在数据字段数组中插入第一列中找到该Application.Index
函数的一些特性
推荐阅读
- javascript - 如何更改点击事件上的标记位置?
- azure - 如何通过 azure-iot-sdk-c 接收设备更新
- audio - 在 ffmpeg 中将图像组合成视频(背景中有音频)
- jquery - jquery中重定向插件的使用
- c# - 如何从 blazor 中的另一个组件启动方法?
- r - 使用calendR(或其他包?)标记日期向量
- oracle - varchar2 上的查询选择无需顶点即可工作
- javascript - map 函数没有在 react.js 中迭代状态对象(数组格式)
- google-sheets-api - Vlookup 列出清单?
- python - Python folium:在 GeoJsonPopup 中显示依赖于 fields=['id'] 的内容