I am writing an excel macro that will copy a sheet from 1 workbook and create a new workbook and remove all the calculations in it.
The problem I am having is copying the logo over. When I run my macro it will hang from time to time either on the picture copy or the picture paste.
This is what I have. I have tried(as you can see from the commented out lines) several fixes.
Sub CopySheets(Actbook As String, newfilestr As String, filestr As String,Sheetstr As String)
'
' NewPriceSheets Macro
'
'
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=newfilestr, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Windows(Actbook).Activate
Worksheets(Sheetstr).Activate
Cells.Select
Selection.Copy
Windows(filestr).Activate
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Windows(Actbook).Activate
Worksheets(Sheetstr).Shapes("Picture 1").Copy
'ActiveSheet.Shapes.Range(Array("Picture 1")).Copy
'Selection.Copy
Windows(filestr).Activate
'Range("A1").Select
'ActiveSheet.Paste
Worksheets(1).Paste Range("A1")
'Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
Windows(Actbook).Activate
Related
I am trying to automate a process. We receive a report that has multiple companies billing information. We currently paste this report into an excel document and it filters out to individual worksheets for each separate company.
We have a macro that copy, paste values to a new worksheet and saves the file. The problem is that the macro saves a file for every worksheet in the excel file and I want to adapt the macro so that it only saves the file where there is billing information for that month.
Therefore we don't have new worksheets saved down, with no billing for the customer.
Currently the macro is set up as below for every customer worksheet.
eg:'BGNBINS
Sheets("BGNBINS").Select
Cells.Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Cells.Select
Cells.EntireColumn.AutoFit
Application.CutCopyMode = False
ActiveWindow.DisplayGridlines = False
'Save the new workbook and close it
ActiveWorkbook.SaveAs Filename:= _
"G:\ACCTG RV\Breena's Admin & JDE\Weighbridge Reports (Breena)\3rd Party Tonnes\Customers 3rd Party\06.2015\BGNBINS 0615 WTS.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
'CONSOLW
Sheets("CONSOLW").Select
Cells.Select
Selection.Copy
Workbooks.Add
'Paste special values and formats
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'resize to fit gridlines
Cells.Select
Cells.EntireColumn.AutoFit
ActiveWindow.DisplayGridlines = False
Range("A1").Select
Application.CutCopyMode = False
'save and close file in specified drive and name
ActiveWorkbook.SaveAs Filename:= _
"G:\ACCTG RV\Breena's Admin & JDE\Weighbridge Reports (Breena)\3rd Party Tonnes\Customers 3rd Party\06.2015\CONSOLW 0615 WTS.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
Sorry you are a bit vague on how the sheet works but is this what you are after?
If ActiveSheet.Range("a1") > 0 Then
'Save the new workbook and close it
ActiveWorkbook.SaveAs Filename:="File Path", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
End If
I'm very new to VBA (as of this morning), so excuse my ignorance. I have a few hundred Excel workbooks, all formatted exactly the same way (just with different text). I'm trying to both format and delete a few sheets within the workbooks (the same for alL).
I recorded a macro that works fine when applied individually, but I'm getting a runtime error when I try to run this as a means of mass format:
Sub LoopFiles()
Dim MyFileName, MyPath As String
Dim MyBook As Workbook
MyPath = "I:\Academic Networks\All scorecard copies, 6.18.2015"
MyFileName = Dir(MyPath & "*.xlsm")
Do Until MyFileName = ""
Workbooks.Open MyPath & MyFileName
Set MyBook = ActiveWorkbook
Application.Run "Workbook1.xlsm!ScorecardMacro"
MyBook.Save
MyBook.Close
MyFileName = Dir
Loop
End Sub
I keep getting a runtime error (9) - Subscript out of range. Any thoughts?
Here's the formatting/deleting I'm trying to apply to all my workbooks (which works fine when applied to one workbook at a time:
Sub ScorecardMacro()
'
' Scorecard Macro
'
'
Sheets.Add
Sheets("Scorecard").Select
Range("D3:D36").Select
Selection.Copy
Sheets("Sheet1").Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("Scorecard").Select
Range("A3:A36").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("Scorecard").Select
Range("F3:I36").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("B3").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Checklist").Select
Range("D4:D27").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveWindow.ScrollColumn = 28
Range("AJ1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("Checklist").Select
Range("A4:A27").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("AJ2").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("Additional Information").Select
Range("A4:B14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("BH1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Program Recommendations").Select
Range("A4:D21").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("BS1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
ActiveWindow.ScrollColumn = 1
Range("A2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
ActiveCell.FormulaR1C1 = _
"=MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1,SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-1)"
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A6"), Type:=xlFillDefault
Range("A2:A6").Select
Sheets("Program Recommendations").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Additional Information").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Scorecard").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Checklist").Select
ActiveWindow.SelectedSheets.Delete
End Sub
The error shows you are trying to access something that doesn't exist.
Since you are deleting something, its better to do all you updates first, then do all the deletes in the end.
If you do some deletes in between and then update, there might be some values/sheets missing
You are referring to a named range called "filename":
"=MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1,SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-1)"
I suspect that name is not defined in the other workbooks.
I'm attempting to write a macro that will copy a range of cells from a sheet, paste them into a sheet ("Bulksheet") that will contain all pasted data, then move on to the next tab after the first sheet. This needs to be done for 40+ tabs. Luckily, the data is in the same place in each tab, including the Bulksheet tab.
I can easily get this to apply to one tab, but returning to the first active tab and then moving on to the next is giving me no end of trouble.
Ex. code (shortened to the crucial bit). At the bottom where Next is would be where I need to move to the next sheet and do the same function, returning to "Bulksheet" and pasting in the next empty cell in column C.:
Sub
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Activate
Range("C100:F103").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Bulksheet").Select
Range("D1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next
End Sub
Try looping through the sheets using an index value instead.
Sub
Dim i as integer
For i = 1 to worksheets.count
sheets(i).Activate
if activesheet.name <> "Bulksheet" then
Range("C100:F103").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Bulksheet").Select
Range("D1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
end if
Next
End Sub
Try this:
Sub CopyToBulksheet()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Bulksheet" Then
ws.Activate
Range("C1:F10").Copy
Sheets("Bulksheet").Select
Range("D" & Cells.Rows.Count).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next
End Sub
I modified a piece of code that opens a .csv file, copies a selected range and pastes it in a selected cell in an excel worksheet.
I am having trouble selecting the next range in the .csv file to paste in the excel file. It only works for the first range (E2:E25).
I want it to select the next range (B2:B25) from the .csv file, copy/paste, but it only selects from the excel file. How do I fix that? Thanks.
Option Explicit
Sub copy2()
Dim FilesToOpen
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim newSheet As Worksheet
FilesToOpen = Application.GetOpenFilename(Title:="Text Files to Open")
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen, Format:=4)
wkbTemp.Sheets(1).Cells.copy
Range("E2:E25").Select
Selection.copy
Windows("Petty Cash Form (test).xls").Activate
Range("H10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B2:B25").Select
Selection.copy
Windows("Petty Cash Form (test).xls").Activate
Range("B10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
wkbTemp.Close
End Sub
In your VBA macro add the line: wkbTemp.Sheets(1).Activate (see 'Activate Source Worksheet):
Option Explicit
Sub copy2()
Dim FilesToOpen
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim newSheet As Worksheet
FilesToOpen = Application.GetOpenFilename(Title:="Text Files to Open")
Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen, Format:=4)
wkbTemp.Sheets(1).Cells.copy
Range("E2:E25").Select
Selection.copy
Windows("Petty Cash Form (test).xls").Activate
Range("H10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Activate Source Worksheet
wkbTemp.Sheets(1).Activate
Range("B2:B25").Select
Selection.copy
Windows("Petty Cash Form (test).xls").Activate
Range("B10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
wkbTemp.Close
End Sub
Hope this may help.
This is somewhat of a rudimentary answer but I would suggest following the VBA hierarchy in order to select specific ranges.
workbook.worksheet.range
I think if you defined the worksheets then used
wrktemp.Sheets("sheet name").Range("E2:E25")
I believe this will help in pursuit of your problem
The error that I am receiving is Run-time error '9': Subscript out of range.
Sub Workbook_Open()
'Turn off any alerts that maybe displayed.
Application.DisplayAlerts = False
'Turn of the screen updates
Application.ScreenUpdating = False
'Declare the workbook, create it, save it and close it
Dim wk As Workbook
Set wk = Workbooks.Add
wk.SaveAs Filename:="C:\Saved File\KPI_Grid.xlsm", FileFormat:=52, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
wk.Close
'Open the workbook again. This will get rid of the 'Compatibilty View' and then activate the orginal workbook
Application.Workbooks.Open Filename:="C:\Saved File\KPI_Grid.xlsm"
Workbooks("KPI Grid V5K1 - macro testing.xlsm").Activate
Worksheets("Weekly").Activate
'Select all cells and copy them
Cells.Select
Selection.Copy
'Activate the workbook and sheet that we are going to paste into.
Workbooks("KPI_Grid.xlsm").Activate
Worksheets("Sheet1").Activate ' ******************ERROR HERE ******************
Cells.Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Activate the previous workbook again.
Workbooks("KPI Grid V5k1 - macro testing.xlsm").Activate
Worksheets("Monthly").Activate
Cells.Select
Cells.Copy
Workbooks("KPI_Grid.xlsm").Activate
Worksheets("Sheet2").Activate
Cells.Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
I thought this was a relatively simple task.
The aim is to create a new workbook, copy the values of two sheets over and then save and close the new workbook.
Why does this code error?
Go to this line Worksheets("Sheet1").Activate
Press F9
Press F5
Check the screen - has the workbook "KPI_Grid.xlsm" been activated ?
Does it actually have a sheet called "Sheet1" ?
If Sheet1 is not in the same workbook as the code then this will naturally error - you need to ensure everything is qualified like this:
ActiveWorkbook.Worksheet("Sheet1").Activate