How do I automate macros to be placed in many workbooks that won't be on my PC

[K0st4din]

Hello everyone,
I have read many things on the internet, but I could not find a solution to my problem. I don't know if there will ever be a macro that can solve my problem. In one workbook I have 28 worksheets. then with a macro I separate 14 workbooks with 2 worksheets in each workbook. I have 2 macros in vba, the 1st is in Thisworkbook, the 2nd is in Module. This is where my problem starts: I transfer these two macros in all 14 workbooks with copy/paste, which totally kills me. Because these macros make it so that they put restrictions on copying, printing, etc., and the 2nd one after certain days totally deletes the workbook. So, if it's just for my excel, I read how to do things, like what file to always have the macros, but in this case, as you can see, it's about 14 workbooks that must have these restrictions, so that different users cannot do anything with the files. I read that there was a way to make a macro or something that was sent to every single user and when they installed it, the macros were implemented in their excels. But that's not a solution because firstly they won't be able to handle it and secondly there's no way I can be sure they will. So my dilemma remains - how can I as quickly as possible put these macros into each workbook and then be able to send the files to the specific people. I hope I have explained well what I am trying to automate. Of course I remain available if I need to explain anything further. And I'm really hoping for some help because I'm desperate to copy and paste every month. Thanks in advance!

 

[K0st4din]

Ahh, you mean, (I didn't get it the first time I read it), yes, to make 14 or as many copies as I need and only have 2 worksheets left inside. However, then how do I give them the necessary names to know 1st which city it is for, 2nd for which etc.

 

[Edgar_]

then how do I give them the necessary names to know 1st which city it is for, 2nd for which etc.

I don't know what code you're using for splitting a file with 28 worksheets into 14 files with 2 worksheets each. It all comes down to seeing what you have to figure out a working approach.

 

[K0st4din]

Since I can't upload the file, I'm attaching a photo.
In column E3 the orange, I choose which city from a drop down menu.
Then with Vlookup in column A3, A4 the city and city+total appear. After that I press Show Sheets (the blue button), this form appears and inside I already have the requested cities marked (now just to mention that in column A3 and down, with this macro, I can also put other Vlookups to call not only 2 worksheets and again with the UserForm to be exported to a separate workbook. So it can be seen that the format is excel and is xlsm , I press OK and the finished file is already with the extracted information in the same place where the parent file is.

 

[Edgar_]

That helps to know what you do, but I still don't know how you're doing it. What happens if you just use something like this
1. Insert a module
2. Add this code

Sub sample()
    Sheets("blagoev").SaveAs ThisWorkbook.Path & "\blagoev", 52
    Sheets("blagoev total").SaveAs ThisWorkbook.Path & "\blagoev total", 52
End Sub

3. Run it
4. Check the same location where your workbook is, there should be two files there
5. Open them
6. Check if they have the code you need included

 

[K0st4din]

One second, one second, I can't upload the file, but I can upload the macro that is in UserForm1

P.S. If I understand correctly with your last macro - to save the file, that means at least 14 button presses to be able to save all the individual workbooks - which again takes me back many clicks.

Option Explicit
Dim rhojas
Dim cargando
Dim setsh As Worksheet

Private Sub CheckBox3_Click()

End Sub

Private Sub CheckBox7_Click()
  Dim i As Long
  For i = 0 To ListBox1.ListCount - 1
    ListBox1.Selected(i) = CheckBox7
  Next
End Sub

Private Sub CommandButton1_Click()
'Por.Dante Amor
    Dim Pdfhojas()
    Dim HojasOcultas()
    Dim hojaactiva As String
    Dim n As Double, m As Double, i As Double, ni As Long
    Dim wvis As Variant, h As Variant
    Dim ruta As String, namePdf As String, nameSh As String
    Dim sh2 As Worksheet
    Dim wname As Name
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    hojaactiva = ActiveSheet.Name
    n = -1
    m = -1
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) Then
            h = ListBox1.List(i)
            n = n + 1
            ReDim Preserve Pdfhojas(n)
            Pdfhojas(n) = h
            wvis = Sheets(h).Visible
            If wvis <> -1 Then
                m = m + 1
                ReDim Preserve HojasOcultas(m)
                HojasOcultas(m) = h
                Sheets(h).Visible = -1
            End If
        End If
    Next
    
    ruta = TextBox1.Value
    
    If n > -1 Then
            
        '
        'Save as PDF
        If CheckBox1.Value = True Then
            If CheckBox6.Value = False Then
                Sheets(Pdfhojas).Select
                ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                    Filename:=ruta & Label2.Caption, _
                    Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                    IgnorePrintAreas:=False, OpenAfterPublish:=False
            Else
                For ni = 0 To UBound(Pdfhojas)
                    
                    nameSh = CStr(Pdfhojas(ni))
                    namePdf = TextBox2.Value & Sheets(nameSh).Range(TextBox3.Value).Value & TextBox4.Value & ".pdf"
                    Sheets(nameSh).ExportAsFixedFormat Type:=xlTypePDF, _
                        Filename:=ruta & namePdf, _
                        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                        IgnorePrintAreas:=False, OpenAfterPublish:=False
                
                Next
            End If
        End If
        '
        'Print
        If CheckBox2.Value = True Then
            Sheets(Pdfhojas).PrintOut
        End If
        '
        'Save as xlsx
        Application.CopyObjectsWithCells = False
        If CheckBox3.Value = True Then
            Application.EnableEvents = False
            Sheets(Pdfhojas).Copy
            ActiveWorkbook.SaveAs _
                Filename:=ruta & Label3.Caption, _
                FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False ' xlOpenXMLWorkbookMacroEnabled, xlExcel12
                
            'Only values and formats
            If CheckBox4.Value = True Then
                For Each sh2 In ActiveWorkbook.Sheets
                    sh2.Cells.Copy
                    sh2.Range("A1").PasteSpecial xlPasteValues
                    sh2.Range("A1").PasteSpecial xlPasteFormats
                Next
            End If
            
            'remove named ranges
            If CheckBox5.Value = True Then
                'On Error Resume Next
                For Each wname In ActiveWorkbook.Names
                    ActiveWorkbook.Names(wname.Name).Delete
                Next
                'On Error GoTo 0
            End If
            
            ActiveWorkbook.Close True
            Application.EnableEvents = True
        End If
        Application.CopyObjectsWithCells = True
        '
        'Guarda archivo como Binario
        'Sheets(hojas).Copy
        'ActiveWorkbook.SaveAs _
            Filename:=ruta & arch, _
            FileFormat:=xlExcel12, CreateBackup:=False
        'ActiveWorkbook.Close False
        '
        'Oculta nuevamente las hojas
        If m > -1 Then
            Sheets(HojasOcultas).Visible = 0
        End If
    End If
    Sheets(hojaactiva).Select
    MsgBox "Finish", vbInformation
End Sub

Private Sub CommandButton2_Click()

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path
        If .Show <> -1 Then
            TextBox1.Value = ThisWorkbook.Path & "\"
        Else
            TextBox1.Value = .SelectedItems(1) & "\"
        End If
    End With

End Sub

Private Sub CommandButton3_Click()
  Unload Me
End Sub
'
Private Sub ListBox1_Change()
'Por.Dante Amor
    Dim i As Double, j As Variant
    
    If cargando Then Exit Sub
    cargando = True
    For i = 0 To ListBox1.ListCount - 1
        For Each j In rhojas
            If LCase(ListBox1.List(i)) = LCase(j.Value) Then
                ListBox1.Selected(i) = True
                Exit For
            End If
        Next
    Next
    cargando = False
End Sub

Private Sub TextBox1_Enter()
    CommandButton2_Click
End Sub

'
Private Sub UserForm_Activate()
'Por.Dante Amor
    Dim rnever As Range, rrango As Range
    Dim uc As Double, j As Variant, ini As Double, fin As Double, k As Double
    Dim xnum As Variant
    Dim existe As Boolean
    Dim h As Worksheet
    Dim arch As String, archPdf As String, archExcel As String
    
    Set setsh = Sheets("set")
    
    Set rhojas = setsh.Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
    Set rnever = setsh.Range("B3:B" & Range("B" & Rows.Count).End(xlUp).Row)
    
    TextBox1.Value = ThisWorkbook.Path & "\"
    uc = setsh.Range("C" & Rows.Count).End(xlUp).Row
    If uc > 2 Then Set rrango = setsh.Range("C3:C" & uc)
    '
    cargando = True
    
    arch = "several sheets"
    If setsh.Range("D3").Value = "" Then
        archPdf = arch
    Else
        archPdf = setsh.Range("D3").Value
    End If
    If setsh.Range("E3").Value = "" Then
        archExcel = arch
    Else
        archExcel = setsh.Range("E3").Value
    End If
    
    Label2.Caption = Replace(setsh.Range("D3") & ".pdf", "/", "-")
    Label3.Caption = Replace(setsh.Range("E3") & ".xlsm", "/", "-")
    
    ListBox1.MultiSelect = 1
    ListBox1.ListStyle = 1
    For Each h In Sheets
        'sheets never select
        existe = False
        For Each j In rnever
            If LCase(h.Name) Like LCase(j.Value) Then
                existe = True
                Exit For
            End If
        Next
        If existe = False Then
            ListBox1.AddItem h.Name
        End If
        '
        'sheets always select
        For Each j In rhojas
            If LCase(h.Name) = LCase(j.Value) Then
                ListBox1.Selected(ListBox1.ListCount - 1) = True
                Exit For
            End If
        Next
        '
        'sheets select
        If uc > 2 Then
            For Each j In rrango
                xnum = Split(j.Value, "-")
                ini = Val(xnum(0))
                fin = Val(xnum(UBound(xnum)))
                For k = ini To fin
                    If h.Index = k Then
                        ListBox1.Selected(ListBox1.ListCount - 1) = True
                        Exit For
                    End If
                Next
            Next
        End If
    Next
    cargando = False
End Sub

 

[K0st4din]

Just adding - I tried the macro but it doesn't.
Because blagoev and blagoev total - should be in one workbook with these two worksheets. In my case it makes two separate files.
Otherwise, Yes, it also takes the macros that are inside, but what is copied, even in one file, also takes all the other worksheets, which is not OK (it goes without saying, somehow separating them).
And the other thing that strikes me is that there are macros that I don't need to copy (which will mean that I only need to say to move for example: Module2 and Module4 and ThisWorkbook (the macros that are inside)

 

[Edgar_]

It seems you have a lot of moving pieces, I think the best approach here is to just do that in another step. Once you have all your exported workbooks, put them all in the same folder and a routine can take care of including the necessary modules.

That involves the file system object, a for loop and trusting the code project, but it would allow me to not touch the rest of the code. I'll come up with something tomorrow.

 

[K0st4din]

And it's a good idea, as you say.
Extract what I need in the individual files, then add the finishing touches with another macro for all the already split workbooks. In this way, we will have a division that, if something becomes necessary, can be more easily modified.
Thank you very much!
See you tomorrow!

 

[Edgar_]

Add a reference to Microsoft Scripting Runtime and adapt this code:

Option Explicit

Private fso As Scripting.FileSystemObject

Public Function GetAFolder(filePath As String) As Scripting.folder
    Set fso = New Scripting.FileSystemObject

    Dim someFolder As Scripting.folder
    Set someFolder = fso.GetFolder(filePath)
   
    Set GetAFolder = someFolder
End Function

Sub ProcessFiles()

    Set fso = New Scripting.FileSystemObject
   
    'access folder
    Dim folder As Scripting.folder
    Set folder = GetAFolder("C:\path\to\your\folder")
   
    'export module to import later
    ThisWorkbook.VBProject.VBComponents("someModule").Export ThisWorkbook.Path & "\someModule.bas"
   
    'declare some vars
    Dim wb As Workbook
    Dim file As Scripting.file
    Dim fileExt As String
    Dim ws As Worksheet
    Dim codeString As String
   
    'loop folder
    For Each file In folder.Files
        'ignore non excel files
        If fso.GetExtensionName(file.Path) = "xlsx" Or fso.GetExtensionName(file.Path) = "xlsm" Then
            'open wb from file
            Set wb = Workbooks.Open(file.Path, False, False)
           
            'import module
            wb.VBProject.VBComponents.Import ThisWorkbook.Path & "\someModule.bas"
           
            'write code to all worksheet modules
            For Each ws In wb.Worksheets
                'get the code
                With ThisWorkbook.VBProject.VBComponents("sheetNameWhereYouHaveSheetCode").CodeModule
                    codeString = .Lines(2, .CountOfLines)
                End With
               
                'write the code
                wb.VBProject.VBComponents(ws.CodeName).CodeModule.AddFromString codeString
            Next ws
           
            'get code from thisworkbook
            With ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
                codeString = .Lines(2, .CountOfLines)
            End With
           
            'write code to the thisworkbook module of target file
            wb.VBProject.VBComponents("ThisWorkbook").CodeModule.AddFromString codeString
           
            'save and close
            wb.SaveAs ThisWorkbook.Path & "\" & Left(wb.Name, Len(wb.Name) - 4) & "xlsm", 52
            wb.Close True
        End If
    Next file
End Sub

Put that code in the parent file. Assuming your parent file has code in a worksheet, ThisWorkbook and a module, this should let you import it. Just configure the folder, the output files will be saved in the same path of your parent file.

This can be further improved in many ways, but I just quickly put it together.

 

[K0st4din]

Hello,
you mean to keep them like this, this way.
Are we continuing with the idea that I have taken out all 14 workbooks ....?