Copying Rows Based on Column Value

[HalfBaked01]

Hello,

New here, I attempted to search for a solution but could not find what I was looking for so thank you in advance.

I am trying to write VBA code to copy rows of data based on a value into a new sheet and save this sheet with a cell value name
[TABLE="width: 500"]
<tbody>[TR]
[TD]Date Header
[/TD]
[TD]Company Header
[/TD]
[TD]Total Amount Header
[/TD]
[TD]Invoice Number
[/TD]
[TD]Invoice Amount
[/TD]
[/TR]
[TR]
[TD]1/17/18
[/TD]
[TD]ABC Company
[/TD]
[TD]$1,000
[/TD]
[TD]12345
[/TD]
[TD]$100
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]12346
[/TD]
[TD]$900
[/TD]
[/TR]
[TR]
[TD]1/17/18
[/TD]
[TD]BCD Company
[/TD]
[TD]$500
[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]1/17/18
[/TD]
[TD]CDE Company
[/TD]
[TD]$450
[/TD]
[TD]ABC123
[/TD]
[TD]-1745
[/TD]
[/TR]
</tbody>[/TABLE]

Above is a sample of what the data looks like, I am attempting to copy based on separate payments that were received.

A few notes;
Company Header will have duplicates
Total Amount could be duplicate but highly unlikely
Invoice Number could be blank
Invoice amount could be blank

Below is how I would like it to look saved as a separate file based on Company name;

[TABLE="width: 500"]
<tbody>[TR]
[TD]Date Header
[/TD]
[TD]Company Header
[/TD]
[TD]Total Amount Header
[/TD]
[TD]Invoice Number
[/TD]
[TD]Invoice Amount
[/TD]
[/TR]
[TR]
[TD]1/17/18
[/TD]
[TD]ABC Company
[/TD]
[TD]$1,000
[/TD]
[TD]12345
[/TD]
[TD]$100
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]12346
[/TD]
[TD]$900
[/TD]
[/TR]
</tbody>[/TABLE]

Again, thank you for your help

-Novice VBA User

 

[HalfBaked01]

I've tried a few things, I can copy the names down and search by that but I am unsure how to make it copy until a new/unique value, even if the company names duplicate/save together it's not that big of a deal. Again any help is appreciated.

 

[HalfBaked01]

Here is something I found that does what I need it to do but it errors on duplicate file names, any help would be appreciated.

Public Sub SplitToFiles()

' MACRO SplitToFiles
' Last update: 2012-03-04
' Author: mtone
' Version 1.1
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
'
' Note: Values in the column should be unique or sorted.
'
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
'
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.

Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created

iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
iFirstRow = iRow

Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path

If Dir(sFilePath + "\Split", vbDirectory) = "" Then
    MkDir sFilePath + "\Split"
End If

'Turn Off Screen Updating  Events
Application.EnableEvents = False
Application.ScreenUpdating = False

Do
    ' Get cell at cursor
    Set rCell = osh.Cells(iRow, iCol)
    sCell = Replace(rCell.Text, " ", "")

    If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
        ' Skip condition met
    Else
        ' Found new section
        If iStartRow = 0 Then
            ' StartRow delimiter not set, meaning beginning a new section
            sSectionName = rCell.Text
            iStartRow = iRow
        Else
            ' StartRow delimiter set, meaning we reached the end of a section
            iStopRow = iRow - 1

            ' Pass variables to a separate sub to create and save the new worksheet
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1

            ' Reset section delimiters
            iStartRow = 0
            iStopRow = 0

            ' Ready to continue loop
            iRow = iRow - 1
        End If
    End If

    ' Continue until last row is reached
    If iRow < iTotalRows Then
            iRow = iRow + 1
    Else
        ' Finished. Save the last section
        iStopRow = iRow
        CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
        iCount = iCount + 1

        ' Exit
        Exit Do
    End If
Loop

'Turn On Screen Updating  Events
Application.ScreenUpdating = True
Application.EnableEvents = True

MsgBox Str(iCount) + " documents saved in " + sFilePath


End Sub

Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)

Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete

End Sub


Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
     Dim ash As Worksheet ' Copied sheet
     Dim awb As Workbook ' New workbook

     ' Copy book
     osh.Copy
     Set ash = Application.ActiveSheet

     ' Delete Rows after section
     If iTotalRows > iStopRow Then
         DeleteRows ash, iStopRow + 1, iTotalRows
     End If

     ' Delete Rows before section
     If iStartRow > iFirstRow Then
         DeleteRows ash, iFirstRow, iStartRow - 1
     End If

     ' Select left-topmost cell
     ash.Cells(1, 1).Select

     ' Clean up a few characters to prevent invalid filename
     sSectionName = Replace(sSectionName, "/", " ")
     sSectionName = Replace(sSectionName, "\", " ")
     sSectionName = Replace(sSectionName, ":", " ")
     sSectionName = Replace(sSectionName, "=", " ")
     sSectionName = Replace(sSectionName, "*", " ")
     sSectionName = Replace(sSectionName, ".", " ")
     sSectionName = Replace(sSectionName, "?", " ")

     ' Save in same format as original workbook
     ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat

     ' Close
     Set awb = ash.Parent
     awb.Close SaveChanges:=False
End Sub

 

[HalfBaked01]

Here is the subsection that will save the items by appending 1 to the end of the save as name, I replaced the ash.SaveAs command with the below code.

Dim iTemp As Integer
      Dim filenamepath As String
      iTemp = 1
      filenamepath = sFilePath + "\Split\" + sSectionName 'addition
        
            Do While Dir(filenamepath & ".xlsx") <> vbNullString
                filenamepath = filenamepath & iTemp
                iTemp = iTemp + 1
            Loop
        ash.SaveAs filenamepath & ".xlsx"