excel - I want to run the same module for every worksheet inside the workbook - Stack Overflow

admin管理员组

文章数量:1122832

I have this code that separate data according to a single column (company name for example), however i have data in several work sheets that i want to split in the same way, and if possible return a work book for containing the two sheets after being separated?

Sub SplitDataByColToWorkbooks()
    ' Updateby Extendoffice
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    Dim xTRg As Range
    Dim xVRg As Range
    Dim xWS As Workbook
    Dim savePath As String
    ' Set the directory to save new workbooks
    savePath = "C:\Users\AddinsVM001\Desktop\multiple files\" ' Modify this path as needed
    Application.DisplayAlerts = False
    Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", Type:=8)
    If TypeName(xVRg) = "Nothing" Then Exit Sub
    vcol = xVRg.Column
    Set ws = xTRg.Worksheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = xTRg.Address(False, False)
    titlerow = xTRg.Row
    ws.Columns(vcol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Cells(1, ws.Columns.Count), Unique:=True
    myarr = Application.Transpose(ws.Cells(1, ws.Columns.Count).Resize(ws.Cells(ws.Rows.Count, ws.Columns.Count).End(xlUp).Row).Value)
    ws.Cells(1, ws.Columns.Count).Resize(ws.Cells(ws.Rows.Count, ws.Columns.Count).End(xlUp).Row).ClearContents
    For i = 2 To UBound(myarr)
        Set xWS = Workbooks.Add
        ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i)
        ws.Range("A" & titlerow & ":A" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Copy
        xWS.Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteAll
        xWS.SaveAs Filename:=savePath & myarr(i) & ".xlsx"

        xWS.Close SaveChanges:=False
    Next i
    ws.AutoFilterMode = False
    Application.DisplayAlerts = True
    ws.Activate
End Sub

Anything would be helpful as i have 0 knowledge in this.

I want to separate a work book with two sheets, containing different data by the companies names, and return a single workbook with two sheets including each company alone.

I have this code that separate data according to a single column (company name for example), however i have data in several work sheets that i want to split in the same way, and if possible return a work book for containing the two sheets after being separated?

Sub SplitDataByColToWorkbooks()
    ' Updateby Extendoffice
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    Dim xTRg As Range
    Dim xVRg As Range
    Dim xWS As Workbook
    Dim savePath As String
    ' Set the directory to save new workbooks
    savePath = "C:\Users\AddinsVM001\Desktop\multiple files\" ' Modify this path as needed
    Application.DisplayAlerts = False
    Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", Type:=8)
    If TypeName(xVRg) = "Nothing" Then Exit Sub
    vcol = xVRg.Column
    Set ws = xTRg.Worksheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = xTRg.Address(False, False)
    titlerow = xTRg.Row
    ws.Columns(vcol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Cells(1, ws.Columns.Count), Unique:=True
    myarr = Application.Transpose(ws.Cells(1, ws.Columns.Count).Resize(ws.Cells(ws.Rows.Count, ws.Columns.Count).End(xlUp).Row).Value)
    ws.Cells(1, ws.Columns.Count).Resize(ws.Cells(ws.Rows.Count, ws.Columns.Count).End(xlUp).Row).ClearContents
    For i = 2 To UBound(myarr)
        Set xWS = Workbooks.Add
        ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i)
        ws.Range("A" & titlerow & ":A" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Copy
        xWS.Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteAll
        xWS.SaveAs Filename:=savePath & myarr(i) & ".xlsx"

        xWS.Close SaveChanges:=False
    Next i
    ws.AutoFilterMode = False
    Application.DisplayAlerts = True
    ws.Activate
End Sub

Anything would be helpful as i have 0 knowledge in this.

I want to separate a work book with two sheets, containing different data by the companies names, and return a single workbook with two sheets including each company alone.

• excel
• vba

Share Improve this question Follow edited Nov 21, 2024 at 15:13 Gustav 55.8k77 gold badges3131 silver badges6161 bronze badges asked Nov 21, 2024 at 14:34 mahmoud zain Zainmahmoud zain Zain 1

Add a comment  | 

1 Answer 1

Sorted by: Reset to default 0

Your question is quite lacking and this site is not meant to be a code provider. You might read the help center perhaps on how to ask a good question. Still here's a first draft on how to open several files and run your macro on them:

Sub SubSelectFiles()
    
    'Declarations.
    Dim VarFileList As Variant
    Dim VarFile As Variant
    Dim WkbFocus As Variant
    
    'Asking the user to specify the files to open.
    VarFileList = Application.GetOpenFilename("Excel document or csv file (*.xls; *.csv), *.xls ;*.csv", , , , True)
    
    'Checking if no file has been specified.
    If VarType(VarFileList) = vbBoolean Then
        
        'Terminating the macro.
        Exit Sub
        
    End If
    
    'Covering each VarFile in VarFileList.
    For Each VarFile In VarFileList
        
        'Opening the file.
        Workbooks.Open Filename:=VarFile
        
        'Setting WkbFocus as the opened workbook.
        Set WkbFocus = Workbooks(Split(VarFile, "\")(UBound(Split(VarFile, "\"))))
        
        'Activating WkbFocus (not strictly necessary as it should already be active).
        WkbFocus.Activate
        
        'Calling the macro.
        Call SplitDataByColToWorkbooks
        
        'Closing WkbFocus.
        WkbFocus.Close SaveChanges:=False
        
    Next
    
End Sub

Be aware that, due to your subroutine structure, you'll have to input the header row and the to-be-split-column in each file. This might be avoided if, for example, each file has the same structure or there is a way to dynamically define those ranges.

本文标签： excelI want to run the same module for every worksheet inside the workbookStack Overflow