VBA create a List from selected inputs on a seperate worksheet

[Gurnek]

All,

I am trying to create a macro which creates a list on a seperate worksheet.

The data i have is arranged in different cells in "Sheet 1" but predominantly looks like:

[TABLE="width: 127"]
<tbody>[TR]
[TD]Room
[/TD]
[TD]No.
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Lecture Rooms
[/TD]
[TD="align: right"]12
[/TD]
[/TR]
[TR]
[TD]Seminar Rooms
[/TD]
[TD="align: right"]3
[/TD]
[/TR]
[TR]
[TD]Dining Hall
[/TD]
[TD="align: right"]2
[/TD]
[/TR]
[TR]
[TD]Sports Hall
[/TD]
[TD="align: right"]2
[/TD]
[/TR]
[TR]
[TD]Activity Rooms
[/TD]
[TD="align: right"]4
[/TD]
[/TR]
</tbody>[/TABLE]


What i am hoping to achieve is a list in the following format but in a different spreadsheet:

[TABLE="width: 160"]
<tbody>[TR]
[TD]Lecture Rooms
[/TD]
[TD="align: right"]1
[/TD]
[/TR]
[TR]
[TD]Lecture Rooms
[/TD]
[TD="align: right"]2
[/TD]
[/TR]
[TR]
[TD]Lecture Rooms
[/TD]
[TD="align: right"]3
[/TD]
[/TR]
[TR]
[TD]Lecture Rooms
[/TD]
[TD="align: right"]4
[/TD]
[/TR]
[TR]
[TD]Lecture Rooms
[/TD]
[TD="align: right"]5
[/TD]
[/TR]
[TR]
[TD]Lecture Rooms
[/TD]
[TD="align: right"]6
[/TD]
[/TR]
[TR]
[TD]Lecture Rooms
[/TD]
[TD="align: right"]7
[/TD]
[/TR]
[TR]
[TD]Lecture Rooms
[/TD]
[TD="align: right"]8
[/TD]
[/TR]
[TR]
[TD]Lecture Rooms
[/TD]
[TD="align: right"]9
[/TD]
[/TR]
[TR]
[TD]Lecture Rooms
[/TD]
[TD="align: right"]10
[/TD]
[/TR]
[TR]
[TD]Lecture Rooms
[/TD]
[TD="align: right"]11
[/TD]
[/TR]
[TR]
[TD]Lecture Rooms
[/TD]
[TD="align: right"]12
[/TD]
[/TR]
[TR]
[TD]Seminar Rooms
[/TD]
[TD="align: right"]1
[/TD]
[/TR]
[TR]
[TD]Seminar Rooms
[/TD]
[TD="align: right"]2
[/TD]
[/TR]
[TR]
[TD]Seminar Rooms
[/TD]
[TD="align: right"]3
[/TD]
[/TR]
[TR]
[TD]Dining Hall
[/TD]
[TD="align: right"]1
[/TD]
[/TR]
[TR]
[TD]Dining Hall
[/TD]
[TD="align: right"]2
[/TD]
[/TR]
[TR]
[TD]Sports Hall
[/TD]
[TD="align: right"]1
[/TD]
[/TR]
[TR]
[TD]Sports Hall
[/TD]
[TD="align: right"]2
[/TD]
[/TR]
[TR]
[TD]Activity Rooms
[/TD]
[TD="align: right"]1
[/TD]
[/TR]
[TR]
[TD]Activity Rooms
[/TD]
[TD="align: right"]2
[/TD]
[/TR]
[TR]
[TD]Activity Rooms
[/TD]
[TD="align: right"]3
[/TD]
[/TR]
[TR]
[TD]Activity Rooms
[/TD]
[TD="align: right"]4
[/TD]
[/TR]
</tbody>[/TABLE]

The list can be generated at any point so i think the start of the macro needs to reset the list produced.


Any help is appreciated.

Regards,


Gurnek.

 

[SteveO59L]

something along the lines of

Dim c As Range, rng
Dim count_val As Integer
Dim room As String

Dim lastrow As Long
Set rng = Range("a2:a6")
For Each c In rng
room = c.Value

count_val = c.Offset(0, 1).Value
Sheets("sheet2").Activate

lastrow = Cells(Rows.count, "a").End(xlUp).Row + 1
Do Until count_val = 0
Range("a" & lastrow).Value = room
count_val = count_val - 1
lastrow = Cells(Rows.count, "a").End(xlUp).Row + 1
Loop
Sheets("sheet1").Activate
Next c

 

[Gurnek]

That is excellent.

I introduced a Sheet2.Cells.Clear to clear the sheet before the macro starts as it seemed to keep adding to the list.

The macro does not seem to give the room number in column B though ...

Any thoughts?

 

[alansidman]

Try this VBA

Option Explicit


Sub Rooms()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = Sheets("Sheet1")
    Set sh2 = Sheets("Sheet2")
    Dim lr1 As Long, lr2 As Long
    lr1 = sh1.Range("B" & Rows.Count).End(xlUp).Row
    lr2 = sh2.Range("B" & Rows.Count).End(xlUp).Row
    Dim i As Long, x As Long
    Dim rn As Long, sn As Long
    
        
    sh2.Range("A1:B" & lr2).ClearContents
    sh2.Range("A1") = "Rooms"
    sh2.Range("B1") = "No."
    
    Application.ScreenUpdating = False
    For i = 2 To lr1
    lr2 = sh2.Range("B" & Rows.Count).End(xlUp).Row
    rn = sh1.Range("B" & i)
    sn = lr2 + 1
    sh1.Range("A" & i).Copy sh2.Range("A" & lr2 + 1)
    
    x = 1
    sh2.Range("B" & sn).Select
    Do Until ActiveCell.Row = rn + sn
        If ActiveCell.EntireRow.Hidden = False Then
            ActiveCell.Value = x
            x = x + 1
        End If
        ActiveCell.Offset(1).Select
    Loop
    Next i
    
    lr2 = sh2.Range("B" & Rows.Count).End(xlUp).Row
    For i = 3 To lr2
    If sh2.Range("A" & i) = "" Then sh2.Range("A" & i) = sh2.Range("A" & i - 1)
    Next i
    Application.ScreenUpdating = True
    
End Sub

 

[Gurnek]

Alan, THanks so Much!!

It seems to be stumbling on the line: sh2.Range("B" & sn).Select

 

[Gurnek]

Thats GRAND alan - it seems to be stumbling on the line: sh2.Range("B" & sn).Select

 

[SteveO59L]

Dim c As Range, rng
Dim count_val As Integer
Dim room As String
Dim room_no As Integer

Dim lastrow As Long
Set rng = Range("a2:a6")
Range("sheet2!a2:b1000").ClearContents
For Each c In rng
room = c.Value
room_no = 1

count_val = c.Offset(0, 1).Value
Sheets("sheet2").Activate

lastrow = Cells(Rows.Count, "a").End(xlUp).Row + 1
Do Until count_val = 0
Range("a" & lastrow).Value = room
Range("b" & lastrow).Value = room_no
room_no = room_no + 1

count_val = count_val - 1
lastrow = Cells(Rows.Count, "a").End(xlUp).Row + 1
Loop
Sheets("sheet1").Activate
Next c

 

[Gurnek]

Steve,

This is Perfect!!!!

THere is one slight tweek, the code does not like the: Range("sheet2!a2:b1000").ClearContents

Is there an alternative way to clear sheet and select a cell? If i delete this line, it returns the list exactly how i want it but directly below the existing list in sheet 1.

Regards,

Gurnek

 

[SteveO59L]

code does not like the: Range("sheet2!a2:b1000").ClearContents

in what way?

 

[Gurnek]

Run-time error 1004

Application-defined or object-defined error.

When i remove this line, it populated the list exactly how i need it on the first sheet under the existing list.

It is almost as thought the sheet 2 activate command isnt recognised neither.