For Next Loop starting with numeric cell

  • Good Afternoon,


    I'm trying to write a macro that on the surface seems pretty straight forward but the solution eludes me. I'm trying to turn a report into a table. The sheet will contain blocks of data with some information in the header which I'm trying to add to the individual rows so we can work with the data as a table.


    The report would look something like this (but messier, with heaps of blank rows in between, and repeated blocks of this data):
    123NZ
    Office: XYZ
    Cost Centre: 77777


    Product Number - Blank column - Description
    123456 - Blank column - 123455 something
    0987766 - blank column - 0987766 another thing


    What I'm trying is do is to place the office and cost centre information in between Product Number and Description. I'm utilising the Blank column and adding another one. (that bit works ...). I also have variables for the office and cost centre but I can't manage to write the code that finds the rows where to insert the data.


    Ultimately, I need two loops because it's blocks of data but before I run, I just want to be able to walk to get the code to manage the first block of data. This means I need a loop that inserts Office and Cost Centre in columns B and C in each row that starts with a cell that contains a number only. I'm trying to use ISNUMERIC but nothing I've tried to for has inserted any data anywhere.

    • I need the code to find the point where to start, i.e. the first row with only numbers in column A.
    • I also need the code to stop whent the numbers end. The following row would either be a blank row or start the next block.


    This is the code so far:


    I haven't found a lot of information on ISNUMERIC and at this point, it's likely that both the code for the loop and the IF function has issues.


    Any help will be much appreciated.


    Thanks,
    Christine
    Auckland

  • Yes, the other data would remain. The end result would be a table with Product Number, Plant, Profit Centre, Storage Location, Description, etc. - all the headers would be removed (my colleague is happy to just sort the data and delete those line once the info in the header has been transferred).
    I have attached an example of what the end result would look like.
    Thanks, Christine

  • I think this does the trick


    [VBA]Option Compare Text


    Sub Report_to_Table()


    Dim Cell As Object, Cellb As Object
    Dim Ws_1 As Worksheet, Ws_2 As Worksheet
    Dim LastRwReport As Long, RwStart As Long, RwEnd As Long, NextRwTable As Long
    Dim strPlant As String, strPC As String, strStgLoc As String


    Set Ws_1 = Worksheets("stock ageing")
    Set Ws_2 = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'create new sheet to build table on


    'find bottom of report output
    LastRwReport = Ws_1.Cells(Rows.Count, "A").End(xlUp).Row


    'bulid new table header
    Ws_1.Range("G9:AF9").Copy Ws_2.Range("H1")
    Ws_1.Range("G11:AF11").Copy Ws_2.Range("H2")
    Ws_2.Range("A2").Value = "Article No"
    Ws_2.Range("B2").Value = "Plant"
    Ws_2.Range("C2").Value = "Profit Centre"
    Ws_2.Range("D2").Value = "Storage Location"
    Ws_2.Range("E2").Value = "Description"



    For Each Cell In Ws_1.Range("A1:A" & LastRwReport)
    If Cell.Value = "423S" Then
    strPlant = Cell.Offset(4, 4).Value
    strPC = Cell.Offset(5, 4).Value
    strStgLoc = Cell.Offset(6, 4).Value
    Debug.Print strPlant, strPC, strStgLoc


    If Cell.Offset(13, 0).Value <> "" Then 'checks if at least 2 article numbers
    RwStart = Cell.Offset(12, 0).Row
    RwEnd = Cell.Offset(12, 0).End(xlDown).Row
    For Each Cellb In Ws_1.Range(Ws_1.Cells(RwStart, 1), Ws_1.Cells(RwEnd, 1))
    NextRwTable = Ws_2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    Ws_1.Cells(Cellb.Row, 1).Copy Ws_2.Cells(NextRwTable, 1)
    Ws_1.Range(Ws_1.Cells(Cellb.Row, 4), Ws_1.Cells(Cellb.Row, 32)).Copy Ws_2.Cells(NextRwTable, 5)
    Ws_2.Cells(NextRwTable, 2).Value = strPlant
    Ws_2.Cells(NextRwTable, 3).Value = strPC
    Ws_2.Cells(NextRwTable, 4).Value = strStgLoc
    Next Cellb
    Else ' if only one article then just copies the one
    NextRwTable = Ws_2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    Ws_1.Cells(Cell.Offset(12, 0).Row, 1).Copy Ws_2.Cells(NextRwTable, 1)
    Ws_1.Range(Ws_1.Cells(Cell.Offset(12, 0), 3), Ws_1.Cells(Cell.Offset(12, 0), 32)).Copy Ws_2.Cells(NextRwTable, 5)
    Ws_2.Cells(NextRwTable, 2).Value = strPlant
    Ws_2.Cells(NextRwTable, 3).Value = strPC
    Ws_2.Cells(NextRwTable, 4).Value = strStgLoc
    End If
    End If
    Next Cell


    End Sub[/VBA]


    This assumes that article numbers will always appear 12 rows below the "423S", which I assume is the report name. I also wasn't sure if you could ever encounter a data block that only listed one item. I didn't copy the report header over because I wasn't sure if it was important but you should be able to modify the code to do that. I think moving it over to a new sheet cleans it up.

  • Hi chavezm3. Thanks for this. Quite a different logic, I think I had started it the wrong way. The report headers are not needed.


    I just tried it and can confirm that there are blocks with only one line and it stops at that block and gives an error at this line:

    Code
    1. Ws_1.Range(Ws_1.Cells(Cell.Offset(12, 0), 3), Ws_1.Cells(Cell.Offset(12, 0), 32)).Copy Ws_2.Cells(NextRwTable, 5)


    The lines that need to come across always have only numbers in column A. So rather than going by empty or not empty at offset, can we go by that?


    Thanks, Christine

  • That's because my dumb self forgot to turn the cell reference into a row for the Cells description, i've updated and tested it out, it looks like it works.


    I went with the empty or not because I wasn't sure how many rows would be populated so in order to set the beginning and end of the loop i had to make sure the .End(xlDown) method wouldn't include empty cells. Otherwise it would have gone from the single article, down to the Total line. This is just how I approached it, if you want to try the IsNumeric method I guess you could try a Do Until loop.



    [vba]
    Option Compare Text


    Sub Report_to_Table()


    Dim Cell As Object, Cellb As Object
    Dim Ws_1 As Worksheet, Ws_2 As Worksheet
    Dim LastRwReport As Long, RwStart As Long, RwEnd As Long, NextRwTable As Long
    Dim strPlant As String, strPC As String, strStgLoc As String


    Set Ws_1 = Worksheets("stock ageing")
    Set Ws_2 = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'create new sheet to build table on


    'find bottom of report output
    LastRwReport = Ws_1.Cells(Rows.Count, "A").End(xlUp).Row


    'bulid new table header
    Ws_1.Range("G9:AF9").Copy Ws_2.Range("H1")
    Ws_1.Range("G11:AF11").Copy Ws_2.Range("H2")
    Ws_2.Range("A2").Value = "Article No"
    Ws_2.Range("B2").Value = "Plant"
    Ws_2.Range("C2").Value = "Profit Centre"
    Ws_2.Range("D2").Value = "Storage Location"
    Ws_2.Range("E2").Value = "Description"



    For Each Cell In Ws_1.Range("A1:A" & LastRwReport)
    If Cell.Value = "423S" Then
    strPlant = Cell.Offset(4, 4).Value
    strPC = Cell.Offset(5, 4).Value
    strStgLoc = Cell.Offset(6, 4).Value


    If Cell.Offset(13, 0).Value <> "" Then 'checks if at least 2 article numbers
    Debug.Print Cell.Offset(12, 0).Row
    RwStart = Cell.Offset(12, 0).Row
    RwEnd = Cell.Offset(12, 0).End(xlDown).Row
    For Each Cellb In Ws_1.Range(Ws_1.Cells(RwStart, 1), Ws_1.Cells(RwEnd, 1))
    NextRwTable = Ws_2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    Ws_1.Cells(Cellb.Row, 1).Copy Ws_2.Cells(NextRwTable, 1)
    Ws_1.Range(Ws_1.Cells(Cellb.Row, 4), Ws_1.Cells(Cellb.Row, 32)).Copy Ws_2.Cells(NextRwTable, 5)
    Ws_2.Cells(NextRwTable, 2).Value = strPlant
    Ws_2.Cells(NextRwTable, 3).Value = strPC
    Ws_2.Cells(NextRwTable, 4).Value = strStgLoc
    Next Cellb
    Else ' if only one article then just copies the one
    NextRwTable = Ws_2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    Ws_1.Cells(Cell.Offset(12, 0).Row, 1).Copy Ws_2.Cells(NextRwTable, 1)
    Ws_1.Range(Ws_1.Cells(Cell.Offset(12, 0).Row, 4), Ws_1.Cells(Cell.Offset(12, 0).Row, 32)).Copy Ws_2.Cells(NextRwTable, 5)
    Ws_2.Cells(NextRwTable, 2).Value = strPlant
    Ws_2.Cells(NextRwTable, 3).Value = strPC
    Ws_2.Cells(NextRwTable, 4).Value = strStgLoc
    End If
    End If
    Next Cell


    End Sub
    [/vba]

  • Hi chavezm9, that looks fantastic. I've noticed that further down it brings in lines starting with 423S, User and Report ID. Working on a big tender today so will cross-check next week and if I get bored, I might still try the IsNumeric method. Until then, if it ain't broke ...!!


    Thank you so much and have a great weekend.


    Christine