How do i set ID for data via VBA - excel

Question

In the picture of the sheet I get my data from "Ark2" and the sheet I get the data to "Ark1". In Ark1 I want want to give an ID for the data. I show an example in yellow, grey, green and blue colours. I want the text ID to stand as it does in the example row "K".
the code is added at the end..
Sub MyProcedure()
a = Worksheets("ark1").Cells(Rows.Count, 1).End(xlUp).Row
MsgBox (a)
End Sub
Private Sub CommandButton1_Click()
Dim nøgletal As String, år As Integer
Worksheets("Ark2").Select
nøgletal = Range("B2")
år = Range("C2")
Worksheets("Ark1").Select
Worksheets("Ark1").Range("A4").Select
ThisWorkbook.Worksheets("Ark1").Range("A1:A100").Value = ThisWorkbook.Worksheets("Ark2").Range("A12:A100").Value
ThisWorkbook.Worksheets("Ark1").Range("B1:B100").Value = ThisWorkbook.Worksheets("Ark2").Range("B12:B100").Value
ThisWorkbook.Worksheets("Ark1").Range("C1:C100").Value = ThisWorkbook.Worksheets("Ark2").Range("C12:C100").Value
ThisWorkbook.Worksheets("Ark1").Range("E1:E100").Value = ThisWorkbook.Worksheets("Ark2").Range("E12:E100").Value
ThisWorkbook.Worksheets("Ark1").Range("G1:G100").Value = ThisWorkbook.Worksheets("Ark2").Range("M12:M100").Value
ThisWorkbook.Worksheets("Ark1").Range("F1:F100").Value = ThisWorkbook.Worksheets("Ark2").Range("N12:N100").Value
ThisWorkbook.Worksheets("Ark1").Range("H1:H100").Value = ThisWorkbook.Worksheets("Ark2").Range("O12:O100").Value
If Worksheets("Ark1").Range("A4").Offset(1, 0) <> "" Then
Worksheets("Ark1").Range("A4").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = nøgletal
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = år
Worksheets("Ark2").Select
Worksheets("Ark2").Range("B2", "B16").Select
End Sub
Sub x()
Dim lngDataColumns As Long
Dim lngDataRows As Long
lngDataColumns = 3
lngDataRows = 15
For t = 1 To lngDataRows
Range("l2").Offset(((t - 1) * lngDataColumns) - 1, 0).Resize(lngDataColumns, 1).Value = _
Application.Transpose(Range("f1:h1").Value)
Range("M2").Offset(((t - 1) * lngDataColumns) - 1, 0).Resize(lngDataColumns, 1).Value = _
Application.Transpose(Range("f1:h1").Offset(t).Value)
Next t
End Sub

Answer 1

A Special Transpose Vol. 2
Adjust the values in the constants section to fit your needs.
The first data row in Range1 (A2:C2) has to have values.
The Code
Sub TransposeAH()
Const cSheet1 As Variant = "Ark1" ' Sheet1 Name/Index
Const cSheet2 As Variant = "Ark1" ' Sheet2 Name/Index
Const cFirst As Integer = 2 ' First Row Number
Const cCol1First As Variant = "A" ' Range1 First Column Letter/Number
Const cCol1Last As Variant = "C" ' Range1 Last Column Letter/Number
Const cCol2First As Variant = "F" ' Range2 First Column Letter/Number
Const cCol2Last As Variant = "H" ' Range2 Last Column Letter/Number
Const cColumns As Integer = 2 ' Number of New Columns
Const cFirstCell As String = "L1" ' Target Range First Cell Address
Dim vntH As Variant ' Range2 Headers
Dim vnt2 As Variant ' Range2 Array
Dim vnt3 As Variant ' Range1 Temp Array (if value is "")
Dim vnt1 As Variant ' Range1 Array
Dim vntT As Variant ' Target Array
Dim LastUR As Long ' Last Used Row
Dim i As Long ' Arrays Row Counter
Dim j As Integer ' Arrays Column Counter
Dim k As Long ' Target Array Rows Counter
Dim m As Integer ' Range1 Temp Array Column Counter
' From Sheet1 to Arrays.
With Worksheets(cSheet1)
' Calculate Last Used Row.
With .Range(.Cells(cFirst, cCol1First), .Cells(.Rows.Count, cCol2Last))
If .Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
Is Nothing Then Exit Sub
LastUR = .Find("*", , , , , 2).Row
End With
' Paste ranges into arrays.
vnt1 = .Range(.Cells(cFirst, cCol1First), .Cells(LastUR, cCol1Last))
vnt2 = .Range(.Cells(cFirst, cCol2First), .Cells(LastUR, cCol2Last))
vntH = .Range(.Cells(cFirst - 1, cCol2First), _
.Cells(cFirst - 1, cCol2Last))
End With
' Resize Target Array.
ReDim vntT(1 To UBound(vnt2) * UBound(vnt2, 2), _
1 To cColumns + UBound(vnt1, 2))
' Write Range2 Array to Target Array.
For i = 1 To UBound(vnt2)
For j = 1 To UBound(vnt2, 2)
k = k + 1
vntT(k, 1) = vntH(1, j)
vntT(k, 2) = vnt2(i, j)
Next
Next
' Resize Range1 Temp Array (if value is "")
ReDim vnt3(1 To 1, 1 To UBound(vnt1, 2))
' Copy first line of Range1 Array to Range1 Temp Array.
For m = 1 To UBound(vnt3, 2)
vnt3(1, m) = vnt1(1, m)
Next
' Write Range1 Array to Target Array.
k = 0
For i = 1 To UBound(vnt1)
For j = 1 To UBound(vnt1, 2)
k = k + 1
For m = 1 To UBound(vnt2, 2)
If vnt1(i, m) <> "" Then
If vnt1(i, m) <> vnt3(1, m) Then
vnt3(1, m) = vnt1(i, m)
End If
End If
vntT(k, m + cColumns) = vnt3(1, m)
Next
Next
Next
' Paste Target Array into Target Range resized
' from Target Range First Cell Address.
With Worksheets(cSheet2).Range(cFirstCell)
.Resize(UBound(vntT), UBound(vntT, 2)) = vntT
End With
End Sub