merge data from multiple columns to single - vba help

[nt_beans]

hello,
I ve a spreadsheet in following format and looking to merge columns and make it to single.

Current:

User	Location	Vendor	CBOT	CME	NYMEX	COMEX
Brian Hoyer	New York	CQG	1		1
Sydney Chen	Los Angeles	CQG		1	1	1
Ram Nivas	Dallas	CQG	1

<tbody>
</tbody>

Desire Output

if cbot or cme or nymex or comex has '1' then i want data in following format:

User	Location	Exchange	Vendor
Brian Hoyer	New York	CBOT	CQG
Brian Hoyer	New York	NYMEX	CQG
Sydney Chen	Los Angeles	CME	CQG
Sydney Chen	Los Angeles	NYMEX	CQG
Sydney Chen	Los Angeles	COMEX	CQG
Ramn Nivas	Dallas	CBOT	CQG

<tbody>
</tbody>

Thanks in advance for your help

 

[mrshl9898]

What column and row does the data start in, and what is the sheet name?

 

[mrshl9898]

This assumes you start in A1 on Sheet1, modify to suit.

Sub summarise()

Dim rownum As Long
Dim rownum2 As Long


Application.ScreenUpdating = False


On Error Resume Next
With ThisWorkbook
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Summary"
End With


Sheets("Summary").Cells(1, 1).Value = "User"
Sheets("Summary").Cells(1, 2).Value = "Location"
Sheets("Summary").Cells(1, 3).Value = "Vendor"
Sheets("Summary").Cells(1, 4).Value = "Exchange"


rownum = 2
rownum2 = 2


Do Until Sheets("Sheet1").Cells(rownum, 1).Value = ""
If Sheets("Sheet1").Cells(rownum, 4).Value = 1 Then
Sheets("Sheet1").Rows(rownum).Copy Sheets("Summary").Rows(rownum2)
Sheets("Summary").Cells(rownum2, 4).Value = "CBOT"
rownum2 = rownum2 + 1
End If
If Sheets("Sheet1").Cells(rownum, 5).Value = 1 Then
Sheets("Sheet1").Rows(rownum).Copy Sheets("Summary").Rows(rownum2)
Sheets("Summary").Cells(rownum2, 4).Value = "CME"
rownum2 = rownum2 + 1
End If
If Sheets("Sheet1").Cells(rownum, 6).Value = 1 Then
Sheets("Sheet1").Rows(rownum).Copy Sheets("Summary").Rows(rownum2)
Sheets("Summary").Cells(rownum2, 4).Value = "NYMEX"
rownum2 = rownum2 + 1
End If
If Sheets("Sheet1").Cells(rownum, 7).Value = 1 Then
Sheets("Sheet1").Rows(rownum).Copy Sheets("Summary").Rows(rownum2)
Sheets("Summary").Cells(rownum2, 4).Value = "COMEX"
rownum2 = rownum2 + 1
End If
rownum = rownum + 1
Loop
Sheets("Summary").Columns("E:G").ClearContents
Sheets("Summary").Columns("C").Insert
Sheets("Summary").Columns("E").Cut Sheets("Summary").Columns("C")
Sheets("Summary").Cells.AutoFit


Application.ScreenUpdating = True


End Sub

 

[nt_beans]

This assumes you start in A1 on Sheet1, modify to suit.

Sub summarise()

Dim rownum As Long
Dim rownum2 As Long


Application.ScreenUpdating = False


On Error Resume Next
With ThisWorkbook
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Summary"
End With


Sheets("Summary").Cells(1, 1).Value = "User"
Sheets("Summary").Cells(1, 2).Value = "Location"
Sheets("Summary").Cells(1, 3).Value = "Vendor"
Sheets("Summary").Cells(1, 4).Value = "Exchange"


rownum = 2
rownum2 = 2


Do Until Sheets("Sheet1").Cells(rownum, 1).Value = ""
If Sheets("Sheet1").Cells(rownum, 4).Value = 1 Then
Sheets("Sheet1").Rows(rownum).Copy Sheets("Summary").Rows(rownum2)
Sheets("Summary").Cells(rownum2, 4).Value = "CBOT"
rownum2 = rownum2 + 1
End If
If Sheets("Sheet1").Cells(rownum, 5).Value = 1 Then
Sheets("Sheet1").Rows(rownum).Copy Sheets("Summary").Rows(rownum2)
Sheets("Summary").Cells(rownum2, 4).Value = "CME"
rownum2 = rownum2 + 1
End If
If Sheets("Sheet1").Cells(rownum, 6).Value = 1 Then
Sheets("Sheet1").Rows(rownum).Copy Sheets("Summary").Rows(rownum2)
Sheets("Summary").Cells(rownum2, 4).Value = "NYMEX"
rownum2 = rownum2 + 1
End If
If Sheets("Sheet1").Cells(rownum, 7).Value = 1 Then
Sheets("Sheet1").Rows(rownum).Copy Sheets("Summary").Rows(rownum2)
Sheets("Summary").Cells(rownum2, 4).Value = "COMEX"
rownum2 = rownum2 + 1
End If
rownum = rownum + 1
Loop
Sheets("Summary").Columns("E:G").ClearContents
Sheets("Summary").Columns("C").Insert
Sheets("Summary").Columns("E").Cut Sheets("Summary").Columns("C")
Sheets("Summary").Cells.AutoFit


Application.ScreenUpdating = True


End Sub

This works great..thanks for your help