VBA to move data to new sheets based off cell values

[DJC105]

Morning All,

I have basic VBA knowledge and was hoping to get some help with one that's not working. I'm working in Excel 365.

Basically I'm taking data that's given and I need to do two main actions: 1. Based off of row G (which have three possible options - admin, operations, construction), break them out into new sheets in the same workbook. Then for one of the options (Operations), I need to break it out based off of five potential values in row M. I'll then be saving all of them into separate files.

I was trying to use this below to seperate it based off of row G. Then I was going to try and use it also for the second part/row M and run it for just the operations sheet.

Thanks!!!

Sub SplitSheetIntoMultipleSheetsBasedOnFundType()
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 objSheet As Excel.Worksheet

Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("G" & objWorksheet.Rows.Count).End(xlUp).Row
Set objDictionary = CreateObject("Scripting.Dictionary")

For nRow = 2 To nLastRow
strColumnValue = objWorksheet.Range("G" & 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)
Set objSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
objSheet.Name = varColumnValue
objWorksheet.Rows(1).EntireRow.Copy objSheet.Rows(1)
For nRow = 2 To nLastRow
If CStr(objWorksheet.Range("G" & nRow).Value) = CStr(varColumnValue) Then
objWorksheet.Rows(nRow).EntireRow.Copy
nNextRow = objSheet.Range("G" & objSheet.Rows.Count).End(xlUp).Row + 1
objSheet.Range("A" & nNextRow).PasteSpecial xlPasteValuesAndNumberFormats
End If
Next
objSheet.Columns("A:Y").AutoFit
Next
End Sub

 

[Tupe77]

Do you mean something like this?

Sub SplitSheetIntoMultipleSheetsBasedOnFundType()
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 objSheet As Excel.Worksheet

' ***** Added for Operations sheet
Dim Rounds As Integer, ColumnLetter As String, i As Integer

For Rounds = 1 To 2
    If Rounds = 1 Then
        Set objWorksheet = ActiveSheet
        ColumnLetter = "G"
    Else
        Set objWorksheet = Worksheets("Operations")
        ColumnLetter = "M"
    End If
' ***** Added for Operations sheet ends
    
    nLastRow = objWorksheet.Range(ColumnLetter & objWorksheet.Rows.Count).End(xlUp).Row
    Set objDictionary = CreateObject("Scripting.Dictionary")
    
    For nRow = 2 To nLastRow
        strColumnValue = objWorksheet.Range(ColumnLetter & 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)
        Set objSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        objSheet.Name = varColumnValue
        objWorksheet.Rows(1).EntireRow.Copy objSheet.Rows(1)
    
        For nRow = 2 To nLastRow
            If CStr(objWorksheet.Range(ColumnLetter & nRow).Value) = CStr(varColumnValue) Then
                objWorksheet.Rows(nRow).EntireRow.Copy
                nNextRow = objSheet.Range(ColumnLetter & objSheet.Rows.Count).End(xlUp).Row + 1
                objSheet.Range("A" & nNextRow).PasteSpecial xlPasteValuesAndNumberFormats
            End If
        Next
        
        objSheet.Columns("A:Y").AutoFit
    Next
    
Next Rounds ' Added for Operations sheet

End Sub

My apologies for any quirks, English is not my native language. "So I blame Google translate for all my goofs."

 

[DJC105]

Do you mean something like this?

Sub SplitSheetIntoMultipleSheetsBasedOnFundType()
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 objSheet As Excel.Worksheet

' ***** Added for Operations sheet
Dim Rounds As Integer, ColumnLetter As String, i As Integer

For Rounds = 1 To 2
    If Rounds = 1 Then
        Set objWorksheet = ActiveSheet
        ColumnLetter = "G"
    Else
        Set objWorksheet = Worksheets("Operations")
        ColumnLetter = "M"
    End If
' ***** Added for Operations sheet ends
   
    nLastRow = objWorksheet.Range(ColumnLetter & objWorksheet.Rows.Count).End(xlUp).Row
    Set objDictionary = CreateObject("Scripting.Dictionary")
   
    For nRow = 2 To nLastRow
        strColumnValue = objWorksheet.Range(ColumnLetter & 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)
        Set objSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        objSheet.Name = varColumnValue
        objWorksheet.Rows(1).EntireRow.Copy objSheet.Rows(1)
   
        For nRow = 2 To nLastRow
            If CStr(objWorksheet.Range(ColumnLetter & nRow).Value) = CStr(varColumnValue) Then
                objWorksheet.Rows(nRow).EntireRow.Copy
                nNextRow = objSheet.Range(ColumnLetter & objSheet.Rows.Count).End(xlUp).Row + 1
                objSheet.Range("A" & nNextRow).PasteSpecial xlPasteValuesAndNumberFormats
            End If
        Next
       
        objSheet.Columns("A:Y").AutoFit
    Next
   
Next Rounds ' Added for Operations sheet

End Sub

My apologies for any quirks, English is not my native language. "So I blame Google translate for all my goofs."

Morning! Sorry for just now responding, I just had a chance to try it out. I appreciate your help!

Quick question, it only works if I have the data copied into a worksheet called Operations. Is there an easy way to change that?

 

[Tupe77]

1. This version asks which sheet M column the data is retrieved from.
(Asks for the sheet index number, which is the position of the sheet in the workbook, counted from the left.)

2. Or you can replace the name Operations in the original code with the name of the sheet you want.

Or did you mean with this:
"Quick question, it only works if I have the data copied into a worksheet called Operations. Is there an easy way to change that?"
something else?

Sub SplitSheetIntoMultipleSheetsBasedOnFundType()
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 objSheet As Excel.Worksheet

' ***** Added for Operations sheet
Dim Rounds As Integer, ColumnLetter As String, i As Integer

For Rounds = 1 To 2
    If Rounds = 1 Then
        Set objWorksheet = ActiveSheet
        ColumnLetter = "G"
    Else
        Set objWorksheet = Worksheets(TS_Fu_AskSheetNumber)
        ColumnLetter = "M"
    End If
' ***** Added for Operations sheet ends
    
    nLastRow = objWorksheet.Range(ColumnLetter & objWorksheet.Rows.Count).End(xlUp).Row
    Set objDictionary = CreateObject("Scripting.Dictionary")
    
    For nRow = 2 To nLastRow
        strColumnValue = objWorksheet.Range(ColumnLetter & 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)
        Set objSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        objSheet.Name = varColumnValue
        objWorksheet.Rows(1).EntireRow.Copy objSheet.Rows(1)
    
        For nRow = 2 To nLastRow
            If CStr(objWorksheet.Range(ColumnLetter & nRow).Value) = CStr(varColumnValue) Then
                objWorksheet.Rows(nRow).EntireRow.Copy
                nNextRow = objSheet.Range(ColumnLetter & objSheet.Rows.Count).End(xlUp).Row + 1
                objSheet.Range("A" & nNextRow).PasteSpecial xlPasteValuesAndNumberFormats
            End If
        Next
        
        objSheet.Columns("A:Y").AutoFit
    Next
    
Next Rounds ' Added for Operations sheet

End Sub

Function TS_Fu_AskSheetNumber(Optional wb As Workbook) As Integer ' Function to request the sheet index number from the user.
If wb Is Nothing Then Set wb = ActiveWorkbook ' If the workbook is not given as a parameter, the activeworkbook is used
Dim SheetNumber As Integer

ReAsk:
SheetNumber = Application.InputBox("Enter Sheet number between 1 to " & wb.Worksheets.Count, Type:=1) ' The type is sheet index number
If SheetNumber < 1 Or SheetNumber > wb.Worksheets.Count Then GoTo ReAsk ' Check that the sheet corresponding to the index is found, if not ReAsk

Dim response As VbMsgBoxResult
    response = MsgBox("Is " & vbCrLf & UCase(wb.Worksheets(SheetNumber).Name) & vbCrLf & "the right sheet to continue? ", vbYesNoCancel)
    
    If response = vbYes Then                ' If the user selects YES, the function return SheetNumber as sheet index.
        TS_Fu_AskSheetNumber = SheetNumber
    ElseIf response = vbNo Then             ' If the user selects NO, the index is asked again.
        GoTo ReAsk
    ElseIf response = vbCancel Then         ' If the user selects CANCEL, the exit function.
        Exit Function
    End If

End Function

My apologies for any quirks, English is not my native language. "So I blame Google translate for all my goofs."