別のシートに行をコピーし、重複するコードを作成する

Question

私の必要に応じてExcelデータを操作する方法を知りたいと思います。

私はいくつかの行を手で選択し、あらかじめ定義された列を持つ別のシートにコピーして、あらかじめ定義された列に合わせて一意のコードを作成したいと考えているテーブルがあります。私は2つの2つの列に基づいて重複を考慮する行。私は写真とよりを説明しますので、

この

は非常に明確ではないかもしれません。

ここ

私は手で選択された行と私のテーブルを持って、私は列H、I、Kをコピーしたいと思います、AA、AJ別のシートへの私の他のテーブルの列に合わせていくつかの特定のために：

私は列A、列Eの私のAA列で私の列Kの私のAJ列を希望します列Fなど...

私はまた、（21から17は、列Bの青いシートで同じキーを持つことになり、ここで最初の画像行の例えば）列F及びIに基づいて独自のキーの

を作成したいでしょう私は自分の選択した行を取り出し、必要な列を別のシートにコピーすることができます。

2番目のシートにテンプレートに合わせて並べ替える方法がわかりません。私はまた、キーを作成し、最初のシートの列FとIの組み合わせごとに、それを2番目のシートに挿入する方法も知らない。

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 

これは実装するのが難しい場合や、不可能な場合は別の方法を見つけるようにコメントに教えてください。私は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