I have a workbook sheet which runs a macro from another workbook. The functions run fine. But the workbook having the macro (which is run from the active sheet) gets open and does not close through vba. I have to manually close it. What can i do to make it close through the code itself so that the other file does remain open
The code is given below
Sub UpdateStockRegister()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Run "'F:\ITEMS.xlsm'!UniqueTransactionItems"
ActiveWorkbook.Close
Dim wbSource As Workbook
Dim wbTarget As Workbook
Set wbTarget = ThisWorkbook
Set wbSource = Workbooks.Open("F:\ITEM REPORT.xlsm")
wbSource.Sheets("TRANSACTION DATA").Copy After:=wbTarget.Sheets("STOCK REGISTER")
wbSource.Close Savechanges = True
Sheets("TRANSACTION DATA").Select
ActiveSheet.Range("A1").EntireRow.Delete
Range("A1").Select
Sheets("TRANSACTION DATA").Select
ActiveSheet.Range("A1").EntireRow.Delete
Range("A1:A15000,B1:B15000,C1:C15000,D1:D15000,E1:E15000,F1:F15000").Select
Selection.Copy
Sheets("STOCK REGISTER").Select
Range("A8").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
Range("A8").Select
Sheets("TRANSACTION DATA").Delete
ActiveWorkbook.Save
End Sub
Related
Im trying to Extract data from multiple Ranges in multiple Excel files, then transpose the copied data preserving the Link option. So under : Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True I added the following code : ActiveSheet.Paste Link:=True
But using this code the macro doesn't correctly link the data. Thank you !
This is the code Im using :
Sub ImportData()
Dim FileNames As Variant
Dim i As Integer
Dim j As Integer
'Application.ScreenUpdating = False
Range("C2").Select
FileNames = Application.GetOpenFilename(FileFilter:="Excel Filter (*.xlsx), *.xlsx", Title:="Open File(s)", MultiSelect:=True)
For i = 1 To UBound(FileNames)
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D45:O45").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D45:O45 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D8:O8").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D8:O8 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D24:O24").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D24:O24 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D33:O33").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D33:O33 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D5:O5").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D5:O5 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D38:O38").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D38:O38 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D108:O108").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D108:O108 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D10: O10 ").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(0, 1).Activate
'D10:O10 Line
Workbooks.Open FileNames(i)
Sheets("Global").Activate
Range("D131:O131").Select
Selection.Copy
Windows("Dashboard.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
ActiveSheet.Paste Link:=True
Workbooks.Open FileNames(i)
ActiveWorkbook.Close savechanges:=False
ActiveCell.Offset(12, -8).Activate
'D131:O131 Line
Next i
End Sub
Paste Link Workaround
Paste Link does not work with Transpose.
Assuming that the code is in the destination workbook and that the results will be written to its ActiveSheet (rather qualify with its name e.g. "Sheet1"), you can use the followng.
The Code
Option Explicit
Sub ImportData()
' Destination
Const dstFirst As String = "C2"
' Source
Const Cols As String = "D:O"
Dim RowNumbers As Variant
RowNumbers = VBA.Array(45, 8, 24, 33, 5, 38, 108, 10, 131)
' Destination
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.ActiveSheet ' Better define: Set ws = wb.worksheets("Sheet1")
Dim dstInit As Range
Set dstInit = ws.Range(dstFirst)
' Source
Dim DataCount As Long
DataCount = ws.Columns(Cols).Count
Dim LB As Long
LB = LBound(RowNumbers)
Dim UB As Long
UB = UBound(RowNumbers)
Dim FileNames As Variant
FileNames = Application.GetOpenFilename( _
FileFilter:="Excel Filter (*.xlsx), *.xlsx", _
Title:="Open File(s)", _
MultiSelect:=True)
Application.ScreenUpdating = False
' Prepare for loop.
Dim src As Range ' Current Source Range
Dim dst As Range ' Current Destination Range
Dim i As Long ' File Names Counter
Dim j As Long ' Destination Rows and Source Columns Counter
Dim n As Long ' Source Rows and Destination Columns Counter
Dim CurForm As String ' Current Left Part of Formula
' Write values from Source to Destination.
For i = 1 To UBound(FileNames)
With Workbooks.Open(FileNames(i)).Worksheets("Global")
CurForm = "='[" & .Parent.Name & "]" & .Name & "'!"
Set dst = dstInit.Offset((i - 1) * DataCount)
For n = LB To UB
Set src = .Columns(Cols).Rows(RowNumbers(n))
For j = 1 To DataCount
dst.Offset(j - 1, n).Formula _
= CurForm & src.Cells(j).Address(0, 0)
Next j
Next n
.Parent.Close SaveChanges:=False
End With
Next i
Application.ScreenUpdating = True
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
End Sub
This is my first question here. I always find answer on google. But now I am lost.
I have been trying, to create a CSV file. Everything was ok but then I found some Cyrillic letters in my export. This problem I solved with following code:
Set shtToExport = ThisWorkbook.Worksheets("Text") 'Sheet to export as CSV
Set wbkExport = Application.Workbooks.Add
shtToExport.Copy Before:=wbkExport.Worksheets(wbkExport.Worksheets.Count)
Application.DisplayAlerts = False 'Possibly overwrite without asking
wbkExport.SaveAs Filename:="C:\Users\" & Environ("username") & "\Desktop\AP Import.csv", FileFormat:=xlUnicodeText
Save file as Unicode text. This solved my problem with Cyrillic letters and question marks were gone.
I was happy until I try to upload this file. Nothing happened.
Then I opened the CSV file, and after closing Excel asked me to save, so I did it and then MSG box "Some features in your workbook might be lost if you save it as Unicode" I pressed yes and tried to upload file again. And it worked perfectly.
But I am not able to put close and save with above mentioned msgbox in code. I tried:
workbooks(AP Import.csv).save
Workbooks(AP Import.csv).close SaveChanges = True
What I want, is open AP import.csv, save, press yes to msgbox "...... you save it as Unicode Text" But I am not able do it with macro. I succeeded to get "Want to save your changes to..." But not unicode msg box. I am using Excel 2013
Here is whole code:
Sub Test()
'
' Test Macro
Application.ScreenUpdating = False
If IsEmpty(ThisWorkbook.Sheets("data").Range("A1")) Then
MsgBox ("Vlož data z WebGate exportu")
Exit Sub
End If
Dim wbkExport As Workbook
Dim shtToExport As Worksheet
Columns("S:W").Select
Selection.Copy
Sheets("Temp").Select
Range("A1").Select
ActiveSheet.Paste
Range("F1").Select
Sheets("data").Select
Columns("E:E").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("E:E,I:I").Select
Range("I1").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Temp").Select
Range("F1").Select
ActiveSheet.Paste
Range("H1").Select
Sheets("data").Select
Columns("L:O").Select
Range("L:O,X:X,Z:Z").Select
Range("Z1").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets("Temp").Select
Range("H1").Select
ActiveSheet.Paste
Range("A2").Select
ActiveWindow.SmallScroll Down:=357
Range("A2:G800").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("To update").Select
Range("A2").Select
ActiveSheet.Paste
Range("H2").Select
Sheets("Temp").Select
Range("N2").Select
ActiveWindow.SmallScroll Down:=354
Range("N2:Q800").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("To update").Select
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Set shtToExport = ThisWorkbook.Worksheets("Text") 'Sheet to export as CSV
Set wbkExport = Application.Workbooks.Add
shtToExport.Copy Before:=wbkExport.Worksheets(wbkExport.Worksheets.Count)
Application.DisplayAlerts = False 'Possibly overwrite without asking
wbkExport.SaveAs Filename:="C:\Users\" & Environ("username") & "\Desktop\AP Import.csv", FileFormat:=xlUnicodeText ' " & Date & "
Application.DisplayAlerts = True
ThisWorkbook.Close savechanges:=False
End Sub
Just add after the save:
wbkExport.Close
I've created a basic macro within a workbook to clear data from a set number of tabs then copy in refreshed data from external workbooks. There is a master data tab within the workbook that uses IF formulas to obtain various stock information for that tab which then feeds through to other sheets.
E.G.
=IF($A$2="","",SUMIF(Data_CoventryStock!$A:$A,Data!$A$2,Data_CoventryStock!$E:$E))
Currently when the macro runs it produces the desired result but the IF Formulas lose the reference to the range e.g. $A:$A becomes #N/A!
I've been looking online for a solution but am unable to see a suitable option. I am new to this area.
Sub Update()
'
' Update Macro
'
Application.DisplayAlerts = False
' Clears data from tabs
Sheets("Data_10Day").Select
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Sheets("Data_CoventryStock").Select
Columns("A:E").Select
Selection.Delete Shift:=xlToLeft
Sheets("Data_CowleyStock").Select
Columns("A:E").Select
Selection.Delete Shift:=xlToLeft
Sheets("Data_RugbyStock").Select
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Sheets("Data_10Day").Select
' Copies data from other workbooks then pastes
Workbooks.Open Filename:= _
"C:\Users\ceasdown\Documents\HDS\Data\Data_10Day.xlsx"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Coventry Ordering Template2.xlsm").Activate
Sheets("Data_10Day").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("Data_10Day.xlsx").Close
Workbooks.Open Filename:= _
"C:\Users\ceasdown\Documents\HDS\Data\Data_CoventryStock.xlsx"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Coventry Ordering Template2.xlsm").Activate
Sheets("Data_CoventryStock").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("Data_CoventryStock.xlsx").Close
Workbooks.Open Filename:= _
"C:\Users\ceasdown\Documents\HDS\Data\Data_CowleyStock.xlsx"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Coventry Ordering Template2.xlsm").Activate
Sheets("Data_CowleyStock").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("Data_CowleyStock.xlsx").Close
Workbooks.Open Filename:= _
"C:\Users\ceasdown\Documents\HDS\Data\Data_RugbyStock.xlsx"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Coventry Ordering Template2.xlsm").Activate
Sheets("Data_RugbyStock").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("Data_RugbyStock.xlsx").Close
Application.DisplayAlerts = True
End Sub
I need it to retain the cell range in the IF formula so no manual update after running the macro is required.
The reason your formulas get damaged is that you are Deleting the ranges they refer to. Instead of deleting, use ClearContents instead.
Also, your code can do with quite a bit of optimsation.
Consider this
Sub Update()
Dim wbMain As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim FilePath As String
Application.DisplayAlerts = False
Set wbMain = ActiveWorkbook
With wbMain
FilePath = Environ$("UserProfile") & "\Documents\HDS\Data\"
' Copies data from other workbooks then pastes
UpdateFromWB .Worksheets("Data_10Day").Cells(1, 1), FilePath & "Data_10Day.xlsx", "WhatSheet?"
UpdateFromWB .Worksheets("Data_CoventryStock").Cells(1, 1), FilePath & "Data_CoventryStock.xlsx", "WhatSheet?"
UpdateFromWB .Worksheets("Data_CowleyStock").Cells(1, 1), FilePath & "Data_CowleyStock.xlsx", "WhatSheet?"
UpdateFromWB .Worksheets("Data_RugbyStock").Cells(1, 1), FilePath & "Data_RugbyStock.xlsx", "WhatSheet?"
End With
Application.DisplayAlerts = True
End Sub
Private Sub UpdateFromWB(rngDest As Range, wbName As String, wsName As String)
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Set wb = Workbooks.Open(Filename:=wbName)
Set ws = wb.Worksheets(wsName)
With ws
Set rng = .Range(.Cells(1, 1).End(xlDown), .Cells(1, 1).End(xlToRight))
'Alternative, in case there might be gaps in the data
'Set rng = .Range(.Cells(.Rows.Count, 1).End(xlUp), .Cells(1, .Columns.Count).End(xlToLeft))
End With
rngDest.Worksheet.Cells.ClearContents 'Delets ALL data from sheet. Adjust range if required
rngDest.Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
wb.Close
End Sub
I try to create a code avoiding .Select, .Activate and repetition. The code is untested but it will give you an idea about the concept. For any question please ask me.
Option Explicit
Sub Update()
Dim ws As Worksheet
'
' Update Macro
'
Application.DisplayAlerts = False
' Clears data from tabs
For Each ws In ThisWorkbook
With ws
If .Name = "Data_10Day" Or .Name = "Data_RugbyStock" Then
.Columns("A:B").Delete Shift:=xlToLeft
ElseIf .Name = "Data_CoventryStock" Or .Name = "Data_CowleyStock" Then
.Columns("A:E").Delete Shift:=xlToLeft
End If
End With
Next ws
' Copies data from other workbooks then pastes
Call Procedure("Data_10Day.xlsx", "Data_10Day")
Call Procedure("Data_CoventryStock.xlsx", "Data_CoventryStock")
Call Procedure("Data_CowleyStock.xlsx", "Data_CowleyStock")
Call Procedure("Data_RugbyStock.xlsx", "Data_RugbyStock.xlsx")
Application.DisplayAlerts = True
End Sub
Sub Procedure(ByVal FileName As String, ByVal SheetName As String)
Workbooks.Open FileName:="C:\Users\ceasdown\Documents\HDS\Data\" & FileName
Workbooks(FileName).Sheets("Sheet1").UsedRange.Copy
Workbooks("Coventry Ordering Template2.xlsm").Sheets(SheetName).Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(FileName).Close
End Sub
Why this call of sub is not working properly?
I get an error that there are undefined objects.
I believe this can be a little problem but cannot find a solution.
I am trying to make new sheetnames but the code is too long for VBA , so I have to split the code, and continue in a second Sub. (apparently it is limited to 15 of 16 handlings)
Thanks in advance.
below my startcode
Sub Macro1()
' Macro1 Macro
Dim wbNew As Workbook
'sheet 1----------------------------------------------------------------
Application.ScreenUpdating = False
ThisWorkbook.Sheets(1).Activate
Range("A1:S53").Select
Range("S53").Activate
Selection.Copy
Set wbNew = Workbooks.Add
wbNew.Sheets(1).Activate
Range("A1:S53").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
wbNew.Sheets(1).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
ActiveSheet.Paste
Range("A15").Select
Call vanaf_17
ActiveWorkbook.SaveAs Filename:= _
"C:\Path\" & "per 1-15" & " " & Format(Range("C13"), "mmmm") & " " & Format(Range("C13"), "YYYY") & ".xlsx"
FileFormat = xlOpenXMLWorkbook
ActiveWindow.Close
End Sub
code to call
Sub vanaf_17()
Dim wbNew As Workbook
Application.ScreenUpdating = False
'sheet 17----------------------------------------------------------------
'here starts a new sheet!!!!!!!!!!!!!
Sheets.Add After:=ActiveSheet
ThisWorkbook.Sheets(1).Activate
Range("A1:S53").Select
Range("S53").Activate
Selection.Copy
'change here sheet nr!!!!!!!
wbNew.Sheets(17).Activate
Range("A1:S53").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'change here sheet nr!!!!!!!
wbNew.Sheets(17).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
ActiveSheet.Paste
'Here ends a new sheet!!!!!
End Sub
You'll need to set wbnew in that second sub as well. The second sub has no idea what you mean when you say wbnew. When you have a variable in a subroutine or function it exists only in the subroutine or function. As soon as you move to another subroutine, your variables are 100% worthless.
To get around this, you can pass parameters between subs.
When you start your second sub Sub vanaf_17() Do it like so:
Sub vanaf_17(wbNew as Workbook)
....your code
End Sub
When you call vanaf_17() do it like so:
Call vanaf_17 webNew
Also, since you are declaring webNew as a workbook in the parameters, delete the dim wbNew as Workbook bit in vanaf_17 otherwise you'll get an error.
Lastly, There is no reason why you need to split these up into two subroutines. I've never heard of '15 or 16 handling' limit and I'm not real sure what that means. I've seen some ugly ass recorded macro code that goes on for thousands of lines of .select and .activate and oh-my-god-no-that-is-such-a-bad-idea for what feels like forever. Excel can handle it.
Updated: Here is what the code would look like with this change:
Sub Macro1()
' Macro1 Macro
Dim wbNew As Workbook
'sheet 1----------------------------------------------------------------
Application.ScreenUpdating = False
ThisWorkbook.Sheets(1).Activate
Range("A1:S53").Select
Range("S53").Activate
Selection.Copy
Set wbNew = Workbooks.Add
wbNew.Sheets(1).Activate
Range("A1:S53").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
wbNew.Sheets(1).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
ActiveSheet.Paste
Range("A15").Select
Call vanaf_17 wbNew
ActiveWorkbook.SaveAs Filename:= _
"C:\Path\" & "per 1-15" & " " & Format(Range("C13"), "mmmm") & " " & Format(Range("C13"), "YYYY") & ".xlsx"
FileFormat = xlOpenXMLWorkbook
ActiveWindow.Close
End Sub
Sub vanaf_17(wbNew AS Workbook)
Application.ScreenUpdating = False
'sheet 17----------------------------------------------------------------
'here starts a new sheet!!!!!!!!!!!!!
Sheets.Add After:=ActiveSheet
ThisWorkbook.Sheets(1).Activate
Range("A1:S53").Select
Range("S53").Activate
Selection.Copy
'change here sheet nr!!!!!!!
wbNew.Sheets(17).Activate
Range("A1:S53").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'change here sheet nr!!!!!!!
wbNew.Sheets(17).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
ActiveSheet.Paste
'Here ends a new sheet!!!!!
End Sub
That being said, there are some changes here that I think will help. Namely, you could loop through all the sheets that you care about in thisWorkbook, and call your subroutine to copy and paste the A1:S53 range into a new worksheet in the new workbook. Below I have a quick example of what that would look like. I kept some of the unnecessary .select and .activate stuff in there, because I figured this change was dramatic enough. You'll see that all of your sheet creation and copying/pasting is now done in the second subroutine. The first subroutine just sets up the new workbook, loops through the sheets, and then saves the new workbook.
Sub Macro1()
' Create a new workbook. Then loop through each worksheet in this workbook (that we care about)
' and call the CreateNewWS subroutine to copy the A1:S53 range for each worksheet into the
' new workbook
Application.ScreenUpdating = False
'Create a new workbook, assign it to wbNew variable
Dim wbNew As Workbook
Set wbNew = Workbooks.Add
'Loop through all the sheets in the current workbook that we care about
Dim sheetname as string
For each sheetname in Array("sheet1", "sheet2", "sheet3", "sheet4")
'call the CreateNewWS subroutine to do the sheet creation and copying and pasting
call CreateNewWS wbNew, thisWorkbook.Sheets(sheetname)
Next sheetname
'You could also loop through all of the worksheets in thisworkbook if you want to copy every worksheet:
'Dim ws as worksheet
'For each ws in ThisWorkbook.Worksheets
' call CreateNewWS wbNew, ws
'Next ws
'Save the new workbook
newWb.SaveAs Filename:= _
"C:\Path\" & "per 1-15" & " " & Format(Range("C13"), "mmmm") & " " & Format(Range("C13"), "YYYY") & ".xlsx"
FileFormat = xlOpenXMLWorkbook
'Close the new workbook
newWb.Close
'Don't forget to turn this back on. Yikes.
Application.ScreenUpdating = True
End Sub
Sub CreateNewWS(wbNew AS Workbook, ws as Worksheet)
'This subroutine takes in the wbNew and the worksheet (ws) that we are copying from.
' it copys range A1:S53 from the ws to the wbNew's new worksheet.
'This will hold the new worksheet we are adding to the wbNew
Dim wsNew as worksheet
'Add a new worksheet to the new workbook
wbNew.Activate
set wsNew = wbNew.Sheets.Add After:=ActiveSheet
'Activate and copy from current workbook
ws.Activate
ws.Range("A1:S53").Select
Selection.Copy
'Activate and paste into newWb
wsNew.Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
I haven't really tested this change, but the guts of it are accurate. If you do decide to switch over to this type of logic and you run into errors, it would be prudent to create a new stackoverflow question to work through the problem.
in the main workbook I start a button that opens the second workbook, then go back to first workbook, copy a range of cells, then go to the second workbook (here it goes wrong) to paste
Sub Knop7_Klikken()
Dim TelStaat As Workbook
Dim Staat As Worksheet
Dim WicamStaat As Workbook
Dim Invoer As Worksheet
Dim Pathname As String
Dim Filename As String
Dim Value1 As String
'TelStaat = "Calculatie 2014 Nesting Wicam.xlsm"
Set TelStaat = ThisWorkbook
Value1 = "AN"
Pathname = "V:\\2013 Calculatie\"
Filename = "VPT.xlsm"
'when I use this it wil not open second macro
Application.EnableEvents = False
Workbooks.Open Filename:=Pathname & Filename
Worksheets("Invoer").Activate
TelStaat.Activate
Worksheets("Staat").Columns(3).Find(Value1).Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Selection.Offset(0, 6).Select
Selection.Resize(, 6).Select
Selection.Copy
'here it goes wrong,
Set WicamStaat = ActiveWorkbook
Worksheets("Invoer").Activate
Range("A32").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.Calculation = True / xlAutomatic
End Sub
Windows("copyfromfile.xlsx").Activate 'Copy
Columns("A:H").Select
Selection.Copy
Windows("pastetofile.xlsx").Activate 'Paste
Columns("A:A").Select
Selection.Insert Shift:=xlToRight