PDA

View Full Version : [SOLVED] Need help with Macro VBA code in Excel



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

p45cal
05-04-2019, 11:51 AM
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
05-05-2019, 06:43 AM
Many many thanks p45cal! You are just awesome! :) :bow::clap:
It works perfectly!
cheers,
Elias