PDA

View Full Version : [SOLVED] Split the excel based on headings list



gopalpithani
07-19-2018, 05:28 AM
i have a heading and some data.next heading and some data. i want split this in to different workbooks containing heading and its data using VBA. Can any one help me in this regard. Thanks in advance.i am attaching main file and sample output file to have an idea.

georgiboy
07-19-2018, 07:11 AM
How about something like:

Sub SelectData()
Dim FirstGT As Range, SecondGT As Range, flName As String
Dim tmpRngEnd As Range, tmpRngStart As Range
Dim wbO As Workbook
Dim wsO As Worksheet

Set tmpRngEnd = Sheet1.Range("B1")

Do
flName = tmpRngEnd.Offset(1, 0).Value
Set FirstGT = Columns("B:B").Find("Grand total", tmpRngEnd)
Set SecondGT = Columns("B:B").Find("Grand total", FirstGT)
Set tmpRngStart = tmpRngEnd
Set tmpRngEnd = SecondGT.Offset(1, 0)
Set tmpRngStart = tmpRngStart.Offset(1, 0)
Set wbO = Workbooks.Add
With wbO
Set wsO = wbO.Sheets("Sheet1")
.SaveAs Filename:="C:\Users\A\Desktop\" & Replace(Replace(flName, ",", ""), ":", "") & ".xlsx"
Sheet1.Range(tmpRngStart.Offset(0, -1), tmpRngEnd.Offset(, 15)).Copy
wsO.Range("A1").PasteSpecial Paste:=xlAll
.Close True
End With
Loop While SecondGT.Offset(2, 0).Value <> ""


End Sub

Hope this helps

gopalpithani
07-19-2018, 08:39 AM
How about something like:

Sub SelectData()
Dim FirstGT As Range, SecondGT As Range, flName As String
Dim tmpRngEnd As Range, tmpRngStart As Range
Dim wbO As Workbook
Dim wsO As Worksheet

Set tmpRngEnd = Sheet1.Range("B1")

Do
flName = tmpRngEnd.Offset(1, 0).Value
Set FirstGT = Columns("B:B").Find("Grand total", tmpRngEnd)
Set SecondGT = Columns("B:B").Find("Grand total", FirstGT)
Set tmpRngStart = tmpRngEnd
Set tmpRngEnd = SecondGT.Offset(1, 0)
Set tmpRngStart = tmpRngStart.Offset(1, 0)
Set wbO = Workbooks.Add
With wbO
Set wsO = wbO.Sheets("Sheet1")
.SaveAs Filename:="C:\Users\A\Desktop\" & Replace(Replace(flName, ",", ""), ":", "") & ".xlsx"
Sheet1.Range(tmpRngStart.Offset(0, -1), tmpRngEnd.Offset(, 15)).Copy
wsO.Range("A1").PasteSpecial Paste:=xlAll
.Close True
End With
Loop While SecondGT.Offset(2, 0).Value <> ""


End Sub

Hope this helps

gopalpithani
07-19-2018, 10:11 AM
Thanks for your timely response,That code is not working for this file, please help me to resolve this.Thanks in advance

georgiboy
07-20-2018, 05:11 AM
The data you are working with is a bit messy, you may want to normalize this data going forwards. This will make achieving things like this in the future much easier.

Try:

Sub SelectData()
Dim strtRng As Range, tCell As Range, rngVar() As String
Dim endRng As Range, maxCol As Long
Dim wbO As Workbook, wsO As Worksheet

'make sure you do not have data to the right of the tables to be copied for maxCol to work
maxCol = Sheet1.UsedRange.Columns.Count
Set strtRng = Sheet1.Range("B2")
Set endRng = strtRng
ReDim Preserve rngVar(0)
rngVar(0) = endRng.Address
x = 1

Do
Set tCell = Columns("B:B").Find("Provider Name:", strtRng)
If tCell = endRng Then Exit Do
ReDim Preserve rngVar(x)
rngVar(x) = tCell.Address
x = x + 1
Set strtRng = tCell
Loop


For x = 0 To UBound(rngVar)
Set wbO = Workbooks.Add
If x < UBound(rngVar) Then
With wbO
Set wsO = wbO.Sheets("Sheet1")
.SaveAs Filename:="C:\Users\A\Desktop\test\" & Replace(Replace(Sheet1.Range(rngVar(x)).Value, ",", "") & "-" & x + 1, ":", "") & ".xlsx"
Sheet1.Range(Sheet1.Range(rngVar(x)).Offset(, -1), Sheet1.Range(rngVar(x + 1)).Offset(-1, maxCol - 2)).Copy
wsO.Range("A1").PasteSpecial Paste:=xlAll
wsO.Cells.EntireColumn.AutoFit
.Close True
End With
Else
With wbO
Set wsO = wbO.Sheets("Sheet1")
.SaveAs Filename:="C:\Users\A\Desktop\test\" & Replace(Replace(Sheet1.Range(rngVar(x)).Value, ",", ""), ":", "") & "-" & x + 1 & ".xlsx"
Sheet1.Range(Sheet1.Range(rngVar(x)).Offset(, -1), Sheet1.Range("B" & Sheet1.Range("B" & Rows.Count).End(xlUp).Row).Offset(, maxCol - 2)).Copy
wsO.Range("A1").PasteSpecial Paste:=xlAll
wsO.Cells.EntireColumn.AutoFit
.Close True
End With
End If
Next x


End Sub

gopalpithani
07-20-2018, 06:15 AM
Thank you so much, you made my life easy with this.