How to iteratively copy each columns in one sheet to different sheets

I am trying to use VBA to realize the following goal:

I have two sheets: "revenue" and "sales tax", and they record the revenue and sales tax of 100 stores from May 1st to May 28th. Now I am trying to create a sheet for each store recording its revenue and sales tax from May 1st to May 28th.

Sub test1()


    Sheets("Sheet1").Select
    Sheets("Sheet1").Copy Before:=Sheets(17)

    Sheets("revenue").Select
    Range("D154:D168").Select
    Selection.Copy

    Sheets("Sheet1 (2)").Select
    Range("C5").Select
    ActiveSheet.Paste

    Sheets("sales tax").Select
    Range("D138:D152").Select
    Application.CutCopyMode = False
    Selection.Copy

    Sheets("Sheet1 (2)").Select
    Range("F5").Select
    ActiveSheet.Paste

    Sheets("Sheet1 (2)").Select
    Sheets("Sheet1 (2)").Name = " reportF "

End Sub

Using this code I am only able to establish a file for 1 store each time. What loop syntax should I use to loop through all stores?

1 answer

  • answered 2019-05-21 12:42 Harassed Dad

    It looks like your data has the store name in column D? This code runs down all cells in column D and copies them into separate sheets depending on the contents

        Sub ExampleCode
        Dim r as range  'declare a pointer variable
        Dim ws as worksheet  'declare a worksheet variable
        set r = Range("d1")  'point to fist cell
        Do   'Start a loop
           If SheetNotExist(r.text) then  'if no sheet of that name
              set ws = worksheets.add(after:=worksheets.count)  'add one
              ws.name = r.text        'and name it as text in r
           End if
           r.copy worksheets(r.text).cells(rows.count,4).end(xlup).offset(1,0)  'copy to next blank cell
           set r = r.offset(1,0) 'shift pointer down one cell
        Loop until r.text = ""  'keep going until r is empty
        End Sub
    
    
       Function SheetNotExist(s as string) as boolean  'check if sheet exists
       On error goto nope  'jump on error
       Dim ws as worksheet
       set ws = worksheets(s)  'this will error if sheet doesn't exist
      'so if we get here the sheet does exist
       SheetNotExist = False 'so return false
       Exit Function 'and go back
       nope:  'we only get here if sheet doesn't exist
       SheetNotExist = True 'so return that
       End Function
    

    Written on my phone - don't have excel so there may be typos - code may not compile therefore,