CODEWITHSUNDEEP
vbaexcel
Hadrien Berthier
Hadrien Berthier

Reputation: 305

Copying row to another sheet and create unique code for duplicate

I would like to know how to manipulate my excel data as I need.

I have a table with rows and a lot of field I would like to select by hand some rows and to copy them to another sheet that has predefined column ordering those rows to fit my predefined column and to create an unique code for rows that I consider duplicate based on 2 two column.

This might not be very clear so I will explain more with photo:

enter image description here

here I have my table with rows I selected by hand, I would like to copy column H,I,K,AA,AJ to another sheet but in some specific order to fit my other table column:

enter image description here

I would like my AJ column in the Column A, my AA column in the Column E My column K in the Column F etc...

I Would also want to create a unique Key based on column F and I (for example here in the first image rows 17 to 21 would have the same key in the blue sheet in column B)

For the moment I am able to take my selected rows and copy the wanted column to another sheet.

I don't know how to reorder them to fit my template in the second sheet. I also don't know how to create a key and insert it to my second sheet for each combination of columns F and I of my first sheet.

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

If this is to complicate to implement or impossible please tell me in comment so that I try to find another method. I am new to VBA and am trying to help my colleagues by simplifying their work.

Thanks.

Upvotes: 1

Views: 95

Answers (1)

Sphinx
Sphinx

Reputation: 660

Maybe try something like this.
It need some adjustements (especially in cells to copy) 

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

Upvotes: 1

Related Questions