Need help with Macro VBA code in Excel

[ezaj]

Dear all,

I have the below code that I am trying to "tweak" a bit so that it saves and closes the files that are generated. (Because when i run it, it opens up sometimes more than 100 files and fills up my memory so the PC crashes.)

--> I need it to save and close the new books that it opens.

Is that possible?

Sub SplitSheetDataIntoMultipleWorkbooksBasedOnSpecificColumn()    Dim objWorksheet As Excel.Worksheet
    Dim nLastRow, nRow, nNextRow As Integer
    Dim strColumnValue As String
    Dim objDictionary As Object
    Dim varColumnValues As Variant
    Dim varColumnValue As Variant
    Dim objExcelWorkbook As Excel.Workbook
    Dim objSheet As Excel.Worksheet
        
     
    Set objWorksheet = ActiveSheet
    nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
 
    Set objDictionary = CreateObject("Scripting.Dictionary")
 
    For nRow = 2 To nLastRow
        'Get the specific Column
        'Here my instance is "B" column
        'You can change it to your case
        strColumnValue = objWorksheet.Range("C" & nRow).Value
 
        If objDictionary.Exists(strColumnValue) = False Then
           objDictionary.Add strColumnValue, 1
        End If
    Next
 
    varColumnValues = objDictionary.Keys
 
    For i = LBound(varColumnValues) To UBound(varColumnValues)
        varColumnValue = varColumnValues(i)
 
        'Create a new Excel workbook
        Set objExcelWorkbook = Excel.Application.Workbooks.Add
        Set objSheet = objExcelWorkbook.Sheets(1)
        objSheet.Name = objWorksheet.Name
 
        objWorksheet.Rows(1).EntireRow.Copy
        objSheet.Activate
        objSheet.Range("A1").Select
        objSheet.Paste
 
        For nRow = 2 To nLastRow
            If CStr(objWorksheet.Range("C" & nRow).Value) = CStr(varColumnValue) Then
               'Copy data with the same column "B" value to new workbook
               objWorksheet.Rows(nRow).EntireRow.Copy
  
               nNextRow = objSheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row + 1
               objSheet.Range("A" & nNextRow).Select
               objSheet.Paste
               objSheet.Columns("A:N").AutoFit
         
            End If
        Next
    Next
End Sub

Thanks and kind regards,
Elias

[p45cal]

Try this (untested and needs ajustment before running, see comments (I've also tweaked it a bit):

Sub SplitSheetDataIntoMultipleWorkbooksBasedOnSpecificColumn2()
Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objExcelWorkbook As Excel.Workbook
Dim objSheet As Excel.Worksheet
         
Set objWorksheet = ActiveSheet
With objWorksheet
  nLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
 
  Set objDictionary = CreateObject("Scripting.Dictionary")
 
  For nRow = 2 To nLastRow
    'Get the specific Column
    'Here my instance is "B" column
    'You can change it to your case
    strColumnValue = .Range("C" & nRow).Value
 
    If objDictionary.Exists(strColumnValue) = False Then
      objDictionary.Add strColumnValue, 1
    End If
  Next
 
  varColumnValues = objDictionary.Keys
 
  For i = LBound(varColumnValues) To UBound(varColumnValues)
    varColumnValue = varColumnValues(i)
 
    'Create a new Excel workbook
    Set objExcelWorkbook = Excel.Application.Workbooks.Add
    Set objSheet = objExcelWorkbook.Sheets(1)
    objSheet.Name = .Name
    .Rows(1).EntireRow.Copy objSheet.Range("A1") 'no selecting required.
    For nRow = 2 To nLastRow
      If CStr(.Range("C" & nRow).Value) = CStr(varColumnValue) Then
        'Copy data with the same column "B" value to new workbook
        nNextRow = objSheet.Range("A" & .Rows.Count).End(xlUp).Row + 1
        .Rows(nRow).EntireRow.Copy objSheet.Range("A" & nNextRow) 'no selecting required.
      End If
    Next nRow
    objSheet.Columns("A:N").AutoFit 'only need to do this once when the sheet is complete.
    myFileNameAndPath = "c:\asd\fgh\hjk\test" & i & ".xlsx" 'you will, of course have to adjust this and make sure the file name is different every time.
    objExcelWorkbook.Close True, myFileNameAndPath 'names, saves and closes the new workbook You may not need to have a variable myFileNameAndPath at all and do it all on this line.
  Next i
End With
End Sub

There might be a snag with determining the next row with
nNextRow = objSheet.Range("A" & .Rows.Count).End(xlUp).Row + 1
because should the row you've just copied over have nothing in column A, the subsequent copy will overwrite the row (all columns). I realise that this may never be the case in your situation, of course. However I prefer this snippet to replace the equivalent section of code above:

    'Create a new Excel workbook
    Set objExcelWorkbook = Excel.Application.Workbooks.Add
    Set objSheet = objExcelWorkbook.Sheets(1)
    objSheet.Name = .Name
    .Rows(1).EntireRow.Copy objSheet.Range("A1") 'no selecting required.
    Set Destn = objSheet.Range("A2")
    For nRow = 2 To nLastRow
      If CStr(.Range("C" & nRow).Value) = CStr(varColumnValue) Then
        'Copy data with the same column "B" value to new workbook
        .Rows(nRow).EntireRow.Copy Destn 'no selecting required.
        Set Destn = Destn.Offset(1)
      End If
    Next nRow

[ezaj]

Many many thanks p45cal! You are just awesome!
It works perfectly!
cheers,
Elias