ezaj
05-04-2019, 06:26 AM
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
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