VBA将行复制到另一个工作表并创build重复的唯一代码

我想知道如何操作我所需要的excel数据。

我有一个表与行和很多字段我想手动select一些行，并将其复制到另一个具有预定义的列sorting这些行以适应我的预定义的列，并创build一个唯一的代码，我认为行基于2两列重复。

这可能不是很清楚，所以我会用照片解释一下：

在这里，我有我手动select的行我的表，我想复制列H，I，K，AA，AJ到另一个工作表，但在一些特定的顺序，以适应我的其他表列：

我想在列A中的AJ列，列E中的列E中的AA列和列F中的列K中的我…

我也想创build一个基于列F和I的唯一键（例如，在第一行中，第17到21行在B列的蓝色表格中将具有相同的键）

目前，我可以把我选定的行并将想要的列复制到另一个表。

我不知道如何重新排列它们以适合我的模板。 我也不知道如何创build一个键，并将其插入到我的第一张表中的F和I列的每个组合我的第二张表。

Sub ajout_commande() Set DataSheet = ThisWorkbook.Worksheets("0") Dim a As Range, b As Range Set a = Selection i = Selection.Rows.Count For Each b In a.Rows DataSheet.Cells(2, 1).EntireRow.Insert Next Dim r1 As Range, r2 As Range, r3 As Rang, r4 As Range, r5 As Range, res_range As Range Let copyrange1 = "I1" & ":" & "I" & i Let copyrange2 = "K1" & ":" & "K" & i Let copyrange3 = "L1" & ":" & "L" & i Let copyrange4 = "AA1" & ":" & "AA" & i Let copyrange5 = "AJ1" & ":" & "AJ" & i Set r1 = a.Range(copyrange1) Set r2 = a.Range(copyrange2) Set r3 = a.Range(copyrange3) Set r4 = a.Range(copyrange4) Set r5 = a.Range(copyrange5) Set res_range = Union(r1, r2, r3, r4, r5) res_range.Copy DataSheet.Cells(2, 1).PasteSpecial xlPasteValues End Sub 

如果这是复杂的实施或不可能请告诉我的评论，所以我试图find另一种方法。 我是VBA的新手，想通过简化工作来帮助我的同事。

谢谢。

Answer 1

也许尝试这样的事情。
它需要一些调整（特别是在单元格复制）

 Dim UniqueKeyArray() As String Dim Counter As Long Sub test() Dim aRows As Range, aCell As Range Dim Ws As Worksheet Dim i As Long Set Ws = ThisWorkbook.Sheets("SomeName") ReDim UniqueKeyArray(0 To 1, 1 To 1) For i = 1 To Selection.Areas.Count 'loop through selection For Each aRows In Selection.Areas(i).Rows 'loop through rows of selection For Each bCell In aRows.Columns(1).Cells 'loop through cells in column one With Ws .Cells(2, 1).EntireRow.Insert 'adjust offset to get source data you need 'adjust cells(x,y) to put data where you want it .Cells(2, 2) = bCell.Offset(0, 2) .Cells(2, 3) = bCell.Offset(0, 3) .Cells(2, 4) = bCell.Offset(0, 5) .Cells(2, 5) = bCell.Offset(0, 6) .Cells(2, 1) = "'" & UniqueKey(bCell.Text) ' "'" added to prevent excel trim leading 000.. End With Next bCell Next aRows Next i 'reset variables. This way you always start unique key from 1 Counter = 0 Erase UniqueKeyArray End Sub Function UniqueKey(SourceVal As String) As String 'creates unique key based on source string Dim i As Long For i = 1 To UBound(UniqueKeyArray, 2) If UniqueKeyArray(1, i) = Format(SourceVal, "0000000000") Then 'if string is same you get unique key created before UniqueKey = UniqueKeyArray(1, i) Exit Function End If Next i 'if string is new then new unique key is created Counter = Counter + 1 ReDim Preserve UniqueKeyArray(0 To 1, 1 To Counter) UniqueKey = Format(Counter, "0000000000") 'adjust format to fit your needs UniqueKeyArray(0, Counter) = SourceVal UniqueKeyArray(1, Counter) = UniqueKey End Function