combine 2 VBA codes

KlausW

KlausW

Active Member
Joined
Sep 9, 2020
Messages
395
Office Version
  1. 2016
Platform
  1. Windows
Hi every one Are there any that can help combine these 2 VBA codes? So that the VBA code collects the 3 sheets with filename in G1 and I can put The file where I want from a dialog box (Application.Dialogs (xlDialogSaveAs) .Show ThisFile, 51) can save the file. All help will be appreciated. Regards Klaus W
VBA Code: 
Sub Rektangelafrundedehjørner5_Klik()

Dim Fname As String, ws As Worksheet
Fname = Sheets("Stamdata").Range("g1").Value
Sheets(Array("1.deling", "2.deling", "3.deling")).Copy
For Each ws In ActiveWorkbook.Worksheets
With ws.UsedRange
.Value = .Value
End With
Next ws
With ActiveWorkbook
.SaveAs Filename:=Fname
.Close
End With
End Sub

Sub Rektangelafrundedehjørner3_Klik()
ThisFile = Range("g1").Value
Application.Dialogs(xlDialogSaveAs).Show ThisFile, 51
End Sub
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
Sort by date Sort by votes
Hi KlausW,
try this code
VBA Code: 
Sub Rektangelafrundedehjørner5_Klik()

    Dim Fname  As String, ws As Worksheet
    Fname = Sheets("Stamdata").Range("g1").Value
    Sheets(Array("1.deling", "2.deling", "3.deling")).Copy
    
    For Each ws In ActiveWorkbook.Worksheets
        With ws.UsedRange
            .Value = .Value
        End With
    Next ws
        
    With ActiveWorkbook
        Application.Dialogs(xlDialogSaveAs).Show Fname, 51
    End With
    
End Sub
 
Upvote 0
Sequoyah said:
Hi KlausW,
try this code
VBA Code: 
Sub Rektangelafrundedehjørner5_Klik()

    Dim Fname  As String, ws As Worksheet
    Fname = Sheets("Stamdata").Range("g1").Value
    Sheets(Array("1.deling", "2.deling", "3.deling")).Copy
   
    For Each ws In ActiveWorkbook.Worksheets
        With ws.UsedRange
            .Value = .Value
        End With
    Next ws
       
    With ActiveWorkbook
        Application.Dialogs(xlDialogSaveAs).Show Fname, 51
    End With
   
End Sub
Click to expand...
Sequoyah said:
Hi KlausW,
try this code
VBA Code: 
Sub Rektangelafrundedehjørner5_Klik()

    Dim Fname  As String, ws As Worksheet
    Fname = Sheets("Stamdata").Range("g1").Value
    Sheets(Array("1.deling", "2.deling", "3.deling")).Copy
   
    For Each ws In ActiveWorkbook.Worksheets
        With ws.UsedRange
            .Value = .Value
        End With
    Next ws
       
    With ActiveWorkbook
        Application.Dialogs(xlDialogSaveAs).Show Fname, 51
    End With
   
End Sub
Click to expand...
Hey Sequoyah.
Thank It works, can U help my white next problem I tried to put it together with the VBA code I send the file with.
Thanks in advance
KW
 
Upvote 0
VBA Code: 
Sub Rektangelafrundedehjørner5_Klik()

 Dim Fname  As String, ws As Worksheet
    Fname = Sheets("Stamdata").Range("g1").Value
    Sheets(Array("1.deling", "2.deling", "3.deling")).Copy
    
    For Each ws In ActiveWorkbook.Worksheets
        With ws.UsedRange
            .Value = .Value
        End With
    Next ws
        
    With ActiveWorkbook
        Application.Dialogs(xlDialogSaveAs).Show Fname, 51
    End With
    
Sheets("Stamdata").Select
    Mail_workbook_Outlook
End Sub

Sub Mail_workbook_Outlook()
'her er koden til at sende mail
    Dim Edress As String, Subj As String
    Dim OutlookOBJ As Object, mItem As Object
    '---------------------------------------------'
    Set OutlookOBJ = CreateObject("Outlook.Application")
    Set mItem = OutlookOBJ.CreateItem(olMailItem)
    With mItem
    
        .To = Sheets("Stamdata").Range("f2").Value
        '& "; " & Range("f3").Value & "; " & Range("f4").Value
        .CC = ""
        .BCC = ""
        .Subject = Sheets("Stamdata").Range("g1").Value
        
        .Body = Range("n1").Value & vbNewLine & vbNewLine & Range("n4").Value & vbNewLine & _
        Range("n5").Value & vbNewLine & Range("n6").Value & vbNewLine & Range("n7").Value & vbNewLine & _
        Range("n8").Value
        
        '.Send                               '<-- .Send will auto send email without review
                                
 ThisWorkbook.Save
        .Attachments.Add ThisWorkbook.Path & "\" & ThisWorkbook.Name
        .Send
    End With

End Sub
 
Upvote 0
Hi Klaus,
thanks for the feedback, here is an updated version of the code
VBA Code: 
Sub Rektangelafrundedehjørner5_Klik()

 Dim Fname  As String, ws As Worksheet, wbk As Workbook
 
 Set wbk = ThisWorkbook
 
    Fname = Sheets("Stamdata").Range("g1").Value
    Sheets(Array("1.deling", "2.deling", "3.deling")).Copy
    
    For Each ws In ActiveWorkbook.Worksheets
        With ws.UsedRange
            .Value = .Value
        End With
    Next ws
        
    With ActiveWorkbook
        Application.Dialogs(xlDialogSaveAs).Show Fname, 51
    End With
    
    With wbk
        .Activate
        .Sheets("Stamdata").Select
    End With
    
    Mail_workbook_Outlook
End Sub

Sub Mail_workbook_Outlook()
'her er koden til at sende mail
    Dim Edress As String, Subj As String
    Dim OutlookOBJ As Object, mItem As Object
    '---------------------------------------------'
    Set OutlookOBJ = CreateObject("Outlook.Application")
    Set mItem = OutlookOBJ.CreateItem(0)
    
        On Error Resume Next

    With mItem
    
        .To = Sheets("Stamdata").Range("f2").Value
        '& "; " & Range("f3").Value & "; " & Range("f4").Value
        .CC = ""
        .BCC = ""
        .Subject = Sheets("Stamdata").Range("g1").Value
        
        .Body = Range("n1").Value & vbNewLine & vbNewLine & Range("n4").Value & vbNewLine & _
        Range("n5").Value & vbNewLine & Range("n6").Value & vbNewLine & Range("n7").Value & vbNewLine & _
        Range("n8").Value
        
        
                                
 ThisWorkbook.Save
        .Attachments.Add ThisWorkbook.Path & "\" & ThisWorkbook.Name
        .Display
        '.Send                               '<-- .Send will auto send email without review
    End With

End Sub
 
Upvote 0
Solution
Sequoyah said:
Hi Klaus,
thanks for the feedback, here is an updated version of the code
VBA Code: 
Sub Rektangelafrundedehjørner5_Klik()

 Dim Fname  As String, ws As Worksheet, wbk As Workbook
 
 Set wbk = ThisWorkbook
 
    Fname = Sheets("Stamdata").Range("g1").Value
    Sheets(Array("1.deling", "2.deling", "3.deling")).Copy
   
    For Each ws In ActiveWorkbook.Worksheets
        With ws.UsedRange
            .Value = .Value
        End With
    Next ws
       
    With ActiveWorkbook
        Application.Dialogs(xlDialogSaveAs).Show Fname, 51
    End With
   
    With wbk
        .Activate
        .Sheets("Stamdata").Select
    End With
   
    Mail_workbook_Outlook
End Sub

Sub Mail_workbook_Outlook()
'her er koden til at sende mail
    Dim Edress As String, Subj As String
    Dim OutlookOBJ As Object, mItem As Object
    '---------------------------------------------'
    Set OutlookOBJ = CreateObject("Outlook.Application")
    Set mItem = OutlookOBJ.CreateItem(0)
   
        On Error Resume Next

    With mItem
   
        .To = Sheets("Stamdata").Range("f2").Value
        '& "; " & Range("f3").Value & "; " & Range("f4").Value
        .CC = ""
        .BCC = ""
        .Subject = Sheets("Stamdata").Range("g1").Value
       
        .Body = Range("n1").Value & vbNewLine & vbNewLine & Range("n4").Value & vbNewLine & _
        Range("n5").Value & vbNewLine & Range("n6").Value & vbNewLine & Range("n7").Value & vbNewLine & _
        Range("n8").Value
       
       
                               
 ThisWorkbook.Save
        .Attachments.Add ThisWorkbook.Path & "\" & ThisWorkbook.Name
        .Display
        '.Send                               '<-- .Send will auto send email without review
    End With

End Sub
Click to expand...
Hi Sequoyah, sorry for the slightly long response time. It just works. thank you very very much. Have a nice day, Best Regards Klaus W
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Conditional Formatting changes from XLSM to XLSX when I use VBA code to save a new file
Replies
1
Views
121
JerrExcel
JerrExcel
S
  • Solved
Add a sequence to the workbook if the same name is found when saving
Replies
8
Views
342
Alex Blakenburg
A
P
  • Question
VBA to import multilpe xml files
Replies
1
Views
134
PippaThePointer
P
KlausW
  • Solved
Show all sheets after the 5 sheets.
Replies
4
Views
70
KlausW
KlausW
A
  • Solved
3 way use button to run macro
Replies
2
Views
112
Aleytha
A

Forum statistics

Threads
1,215,731
Messages
6,126,539
Members
449,316
Latest member
sravya

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top