Click here to Skip to main content
15,113,873 members
Please Sign up or sign in to vote.
1.00/5 (2 votes)
See more:
Hi,

I want to create a macro with the below requirement:-

A	B	C
1234	Color	 Blue
1234	Width	 1.5"
1234	Supplier XYX

output required
A        Colour  Width   Supplier
1234     Blue    1.5"     XYX


What I have tried:

I want to create a macro using VBA code.
Posted
Updated 25-Mar-19 3:53am
v2
Comments
Mohibur Rashid 25-Mar-19 6:01am
   
And? What prblem are you facing?
chints786 25-Mar-19 6:17am
   
I havent created a macro yet. so I dont know how it is made.

On internet i found the below code


Option Explicit


Sub ATransProd()
Application.ScreenUpdating = False
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Input")
Set s2 = Sheets("OutputX")
s2.Range("A1") = s1.Range("A1")
s2.Range("B1") = "Producto"
s2.Range("C1") = "Unidad"
s1.Range("L1:N1").Copy s2.Range("D1")
Dim lr As Long, lr2 As Long, i As Long
lr = s1.Range("A" & Rows.Count).End(xlUp).Row
With s1
For i = 2 To lr
lr2 = s2.Range("B" & Rows.Count).End(xlUp).Row
.Range("A" & i).Copy s2.Range("A" & lr2 + 1)
.Range("B" & i & ":F" & i).Copy
s2.Range("B" & lr2 + 1).PasteSpecial xlPasteValues, , , True
.Range("G" & i & ":K" & i).Copy
s2.Range("C" & lr2 + 1).PasteSpecial xlPasteValues, , , True
.Range("L" & i & ":N" & i).Copy s2.Range("D" & lr2 + 1)
Next i
End With
Application.CutCopyMode = False
lr2 = s2.Range("B" & Rows.Count).End(xlUp).Row
For i = lr2 To 2 Step -1
If s2.Range("C" & i) = "" Then
s2.Range("C" & i).EntireRow.Delete
End If
Next i
With s2
For i = 3 To lr2
If .Range("A" & i) = "" Then
.Range("A" & i) = .Range("A" & i - 1)
.Range("D" & i) = .Range("D" & i - 1)
.Range("E" & i) = .Range("E" & i - 1)
.Range("F" & i) = .Range("F" & i - 1)
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "completed"
End Sub

Assuming that a worksheet #1 contains the data listed below, started from A1 cell:

ID	Property	Value
1234	Color	Blue
1234	Width	1.5"
1234	Supplier	XYX
1235	Color	Orange
1235	Width	3.5"
1235	Supplier	ZZA


and you want to achieve something like that (in a #2 worksheet):
ID	Color	Width	Supplier
1234	Blue	1.5"	XYX
1235	Orange	3.5"	ZZA


below macro should do the job:

VB
Option Explicit

Sub RowsToColumns()
    Dim i As Integer, j As Integer, k As Integer
    Dim srcWsh As Worksheet, dstWsh As Worksheet
    
    On Error GoTo Err_RowsToColumns

    'you need to change a code-context!
    'read below comments
    Set srcWsh = ThisWorkbook.Worksheets(1) 'refers to first worksheet in a workbook - source worksheet
    Set dstWsh = ThisWorkbook.Worksheets(2) 'refers to second worksheet in a workbook - destination worksheet
    dstWsh.Cells.Delete xlShiftUp 'clean up first!
    With dstWsh.Range("A1")
        .Value = "ID"
        .Font.Bold = True
        .Interior.Color = vbGreen
    End With
    
    i = 2
    j = 2
    Do While srcWsh.Range("A" & i) <> ""
        'ID
        dstWsh.Range("A" & j) = srcWsh.Range("A" & i)
        'other properties
        k = 0
        Do While srcWsh.Range("A" & i + k) = srcWsh.Range("A" & i)
            With dstWsh.Range("B1").Offset(ColumnOffset:=k)
                .Value = srcWsh.Range("B" & i + k)
                .Font.Bold = True
                .Interior.Color = vbGreen
            End With
            dstWsh.Range("B" & j).Offset(ColumnOffset:=k) = srcWsh.Range("C" & i + k)
            k = GetColumnNo(srcWsh.Range("B" & i + k), dstWsh)
        Loop
        i = i + k
        j = j + 1
    Loop
    
Exit_RowsToColumns:
    On Error Resume Next
    Set srcWsh = Nothing
    Set dstWsh = Nothing
    Exit Sub

Err_RowsToColumns:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_RowsToColumns


End Sub

Function GetColumnNo(sHeader As String, wsh As Worksheet) As Integer
    Dim c As Integer
    
    c = 0
    Do While wsh.Range("A1").Offset(ColumnOffset:=c) <> ""
        If wsh.Range("A1").Offset(ColumnOffset:=c) = sHeader Then Exit Do
        c = c + 1
    Loop
    
    GetColumnNo = c

End Function


Note: the data and above macro should be in the same workbook.
   
Comments
chints786 25-Mar-19 10:33am
   
Hi Maciej,

I am getting error "subscript out of range"
Maciej Los 25-Mar-19 10:37am
   
Because you didn't read my comments...
chints786 25-Mar-19 10:49am
   
Probably i tried changing some code based on your comments but i may be wrong.

'you need to change a code-context!
'read below comments
Set srcWsh = Sheet1 'refers to first worksheet in a workbook - source worksheet
Set dstWsh = sheet2 'refers to second worksheet in a workbook - destination worksheet
dstWsh.Cells.Delete xlShiftUp 'clean up first!
With dstWsh.Range("A1")
.Value = "ID"
.Font.Bold = True
.Interior.Color = vbGreen
End With

was this which was required?
Maciej Los 27-Mar-19 3:08am
   
Replace:
Set srcWsh = Sheet1

with:
Set srcWsh = ThisWorkbook.Worksheets("Sheet1") 'where Sheet1 is the name of sheet
chints786 2-Apr-19 7:58am
   
Thanks a ton Maciej. I was able to do the necessary changes. Once again thanks for your help!!!
Maciej Los 3-Apr-19 16:42pm
   
You're very welcome.
Please, accpet my answer (green button), if my answer was helpful.
chints786 5-Apr-19 13:23pm
   
Done.

Thanks once again!!
Maciej Los 5-Apr-19 17:00pm
   
Thanks!
Use the Macro Record feature.
- Start recording
- Perform the actions you want
- Stop recording.
You can now edit and modify the macro as required.
   
Comments
chints786 25-Mar-19 6:17am
   
Richard i want to create a macro, I haven't created it anytime
so please help me to create it.
Richard MacCutchan 25-Mar-19 6:35am
   
Follow the instructions above. Alternatively read Quick start: Create a macro - Office Support[^].

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)




CodeProject, 20 Bay Street, 11th Floor Toronto, Ontario, Canada M5J 2N8 +1 (416) 849-8900