Appendix Thread 2. ( Codes for other Threads, HTML Tables, etc.)

**DocAElstein** · 03-20-2018, 04:09 PM

Second Code for RaghavendraPrabhu
For this Post in main Excel Forum
http://www.excelfox.com/forum/showth...0541#post10541

Code:


Option Explicit

' https://stackoverflow.com/questions/46368771/how-to-create-a-new-workbook-for-each-unique-value-in-a-column?rq=1
' http://www.excelfox.com/forum/showthread.php/2237-Make-macro-create-unique-files-only-once-If-files-exist-amend-them
Sub ExportByName()
Dim unique(1000) As String
Dim wb(1000) As Workbook
Dim ws As Worksheet
Dim x As Long
Dim y As Long
Dim ct As Long
Dim uCol As Long

'On Error GoTo ErrHandler

'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual

'Your main worksheet info.
 Set ws = ActiveWorkbook.Sheets("Sheet1")
 Let uCol = 7 'Column G
Dim Strt As Long, Stp As Long: Let Strt = ws.Cells(ws.Rows.Count, 6).End(xlUp).Row + 1: Stp = ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
 Let ws.Range("F" & Strt & ":F" & Stp & "").Value = Format(Date, "dd mmm yyyy") ' adding the dates to the new rows
 Let ws.Range("A" & Strt & ":A" & Stp & "").Value = Application.Evaluate("=row(" & Strt & ":" & Stp & ")-1") ' adding the S.no. to the new rows

ct = 0

'get a unique list of users
For x = 2 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
    If CountIfArray(ActiveSheet.Cells(x, uCol), unique()) = 0 Then
        unique(ct) = ActiveSheet.Cells(x, uCol).Text
        ct = ct + 1
    End If
Next x

'loop through the unique list
  For x = 0 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row - 1
    If unique(x) <> "" Then
    If Dir(ThisWorkbook.Path & "\" & unique(x) & ".xlsx", vbNormal) = "" Then 'If unique file does not exist
        'add workbook
        Workbooks.Add: Set wb(x) = ActiveWorkbook
        ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)
    Else ' open workbook
     Workbooks.Open Filename:=ThisWorkbook.Path & "\" & unique(x) & ".xlsx"
     Set wb(x) = ActiveWorkbook
    End If

        
        'loop to find matching items in ws starting from where column F ( 6 )  has no entry and copy over
        'For y = ws.Cells(ws.Rows.Count, 6).End(xlUp).Row + 1 To ws.Cells(ws.Rows.Count, uCol).End(xlUp).Row
        For y = Strt To Stp
            If ws.Cells(y, uCol) = unique(x) Then
                'copy full formula over
                'ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1)
                'to copy and paste values
                ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy
                wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                'wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)), 6).Value = Format(Date, "dd mmm yyyy")
            End If
        Next y
        'autofit
        wb(x).Sheets(1).Columns.AutoFit
        'save when done
        wb(x).SaveAs ThisWorkbook.Path & "\" & unique(x) & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False     '   & " " & Format(Now(), "mm-dd-yy")
        wb(x).Close SaveChanges:=True
    Else
        'once reaching blank parts of the array, quit loop
        Exit For
    End If

  Next x
'' Master File change to current date:
'Dim Lr As Long: Let Lr = ws.Cells(Rows.Count, 6).End(xlUp).Row
' ws.Range("F2:F" & Lr & "").Value = Format(Date, "dd mmm yyyy")

' Application.ScreenUpdating = True
' Application.Calculation = xlCalculationAutomatic

ErrHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Public Function CountIfArray(lookup_value As String, lookup_array As Variant)
    CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
End Function