Want to split up a worksheet in many worksheets based on column information RRS feed

  • Question

  • Hi,

    I have an accounting worksheet for the happenings with two columns for each account - there are 7 such sets in this one book.

    I want to get each set on it's own worksheet with empty rows (for values in the columns that are specific for this account) deleted.

    There are 4 header columns (a-d) and 6 header rows (1-6) that I want to appear on each worksheet.

    Here I'd like to get 7 output worksheets (into same file - that already contains a few other worksheets than the one that is Input).  Headers for the accounts are in E5:F6  +  G5:G6 + I5:J6 + K5:L6 + M5:N6 + O5:P6 and Q5:R6 - 

    The entry is in E5, G5, I5, K5, M5, O5 and Q5 respectively.

    First output worksheet:

    Would like rows: 1-6 + all rows that contain a value (not null) on rows in either column E or F until the last row (here row 26).

    Would like columns: A-D + E + F 

    Formatting as in the input sheet.

    Second output worksheet: Same as above but instead of columns E or F, it should be Column G or H...

    And so forth...

    I've seen some threads here that do parts of this, but for Rows based on data in them..

    This one seems pretty close to what I needed, but I struggle with getting it modified...

    Can one of you help? Thanks in advance,

    Br Tarja

    Monday, February 24, 2020 5:16 PM

All replies

  • Here is a macro. Make sure that the sheet with the data is the active sheet when you run it.

    Sub SplitData()
        Dim wshS As Worksheet
        Dim wshT As Worksheet
        Dim c As Long
        Dim t As Long
        Dim m As Long
        Application.ScreenUpdating = False
        Set wshS = ActiveSheet
        For c = 5 To 17 Step 2
            Set wshT = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            wshT.Name = wshS.Cells(5, c).Value
            wshS.Range("A:D").Copy Destination:=wshT.Range("A1")
            wshS.Range("E:F").Offset(0, c - 5).Copy Destination:=wshT.Range("E1")
            m = wshT.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            For t = m To 7 Step -1
                If wshT.Range("E" & t).Value = "" And wshT.Range("F" & t).Value = "" Then
                    wshT.Range("A" & t).EntireRow.Delete
                End If
            Next t
        Next c
        Application.ScreenUpdating = True
    End Sub

    Regards, Hans Vogelaar (

    Monday, February 24, 2020 7:12 PM