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:
[TABLE="width: 500"]
<tbody>[TR]
[TD]User[/TD]
[TD]Location[/TD]
[TD]Vendor[/TD]
[TD]CBOT[/TD]
[TD]CME[/TD]
[TD]NYMEX[/TD]
[TD]COMEX[/TD]
[/TR]
[TR]
[TD]Brian Hoyer[/TD]
[TD]New York[/TD]
[TD]CQG[/TD]
[TD]1[/TD]
[TD][/TD]
[TD]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Sydney Chen[/TD]
[TD]Los Angeles[/TD]
[TD]CQG[/TD]
[TD][/TD]
[TD]1[/TD]
[TD]1[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]Ram Nivas[/TD]
[TD]Dallas[/TD]
[TD]CQG[/TD]
[TD]1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Desire Output

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

[TABLE="width: 500"]
<tbody>[TR]
[TD]User[/TD]
[TD]Location[/TD]
[TD]Exchange[/TD]
[TD]Vendor[/TD]
[/TR]
[TR]
[TD]Brian Hoyer[/TD]
[TD]New York[/TD]
[TD]CBOT[/TD]
[TD]CQG[/TD]
[/TR]
[TR]
[TD]Brian Hoyer[/TD]
[TD]New York[/TD]
[TD]NYMEX[/TD]
[TD]CQG[/TD]
[/TR]
[TR]
[TD]Sydney Chen[/TD]
[TD]Los Angeles[/TD]
[TD]CME[/TD]
[TD]CQG[/TD]
[/TR]
[TR]
[TD]Sydney Chen[/TD]
[TD]Los Angeles[/TD]
[TD]NYMEX[/TD]
[TD]CQG[/TD]
[/TR]
[TR]
[TD]Sydney Chen[/TD]
[TD]Los Angeles[/TD]
[TD]COMEX[/TD]
[TD]CQG[/TD]
[/TR]
[TR]
[TD]Ramn Nivas[/TD]
[TD]Dallas[/TD]
[TD]CBOT[/TD]
[TD]CQG[/TD]
[/TR]
</tbody>[/TABLE]

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