So I have produced this code so far, but I cannot get the paste to work.
The idea is run through 190 workbooks and to paste formulas in some cells with constants in others (range H1:Z160) which grade an excel exam. All the formulas and constants paste and work if done manually.
The paste function (labelled) fails with this error:
This is the now updated and corrected code:
Option Explicit
Sub Examnew()
Dim rCell As Range, rRng As Range 'define loop names
Dim wbmaster As Workbook 'name for master workbook
Dim wbtarget As Workbook 'name for student workbook
Set wbmaster = ActiveWorkbook 'set the name for the master
Dim i As Long 'a counter for the result pasteback
With Application '<--|turn off screen & alerts only removed while testing
.ScreenUpdating = False
.EnableEvents = False
End With
i = 1 'Set the counter for result paste back
'Student numbers in cells B3:B136 WARNING SET TO 2 STUDENTS ONLY FOR TEST
'NOTE that st Nums are in col B with a duplicate in col A to collect results.
Set rRng = wbmaster.Sheets("studentlist").Range("B3:B4")
ActiveSheet.DisplayPageBreaks = False '< | turn off page breaks for speed
For Each rCell In rRng '< | loop through "students" range
ActiveSheet.DisplayPageBreaks = False '< | turn off page breaks for speed
'now open Student exam workbook and set to name "wbtarget"
Workbooks.Open ("/Users/michael/Final_V1/" & rCell.Value & ".xlsx")
Set wbtarget = Workbooks(rCell.Value & ".xlsx")
'do copy & paste from Master to Target
wbmaster.Sheets("Answers_Source").Range("h1:z160").Copy
wbtarget.Sheets("ANSWERS").Range("h1:z160").PasteSpecial
Application.CutCopyMode = False 'Clear the copy command
'Now collect the result in cell I4 and paste it back into column B using the rCell
'for that student number matches the st num in col A
wbtarget.Sheets("Answers").Range("I4").Copy
wbmaster.Sheets("studentlist").Range("B" & 2 + i).PasteSpecial xlPasteValues
Application.CutCopyMode = False 'Clear the copy command
'now save and close the student file...
wbtarget.Close (True)
i = i + 1 'increment i for next pasteback
Next rCell '< | next student number
'save the results file
wbmaster.Save
ActiveSheet.DisplayPageBreaks = True '< | turn back on page breaks once all done
'turn screen & alerts back on
With Application
.ScreenUpdating = True: .DisplayAlerts = True
'.DisplayPageBreaks = True
End With
End Sub
Which works perfectly, Thanks guys.
The reason it fails on that line of code is that there is no Paste method for the Range object.
There are 2 ways to copy paste.
1) Send a value to the Destination parameter in the Copy method. You then don't need a Paste command:
wb.Sheets("Answers_Source").Range("h1:z160").Copy _
Destination := wb2.Sheets("Answers").Range("h1:z160")
2) Use the PasteSpecial method on the destination range after copying, which by default pastes everything, like a standard paste.
wb2.Sheets("Answers").Range("h1:z160").PasteSpecial
Then to stop the Marquee (or marching ants) around the cell you copied, finish with Application.CutCopyMode = False
Even though this has been answered, the Range Value property is something that should be included as an option for this question.
If you're only looking to CopyPasteValues, it is probably better to adjust the Range Value Property to be equal to the Source Range Values.
A couple advantages:
No marching ants (Application.CutCopyMode = False).
The screen should not need to flash update/scroll.
Should be faster.
You don't even need to unhide or activate (which you don't with Copying, but people think you do... so I'm listing it!).
So I rebuilt your Macro with the changes, though I didn't make any other changes, so whatever else you fixed, would probably need to be done again. I also included a second macro (TimerMacro) that you can use to time how long it runs (in case you want to test the performance differences). If you're not using any dates, you can use the property Value2 for a very slight speed improvement, although I haven't seen much improvement with this.
Good Luck!
Sub Examnew_NEW()
Dim rCell As Range, rRng As Range 'define loop names
Dim wbmaster As Workbook 'name for master workbook
Dim wbtarget As Workbook 'name for student workbook
Set wbmaster = ActiveWorkbook 'set the name for the master
Dim i As Long 'a counter for the result pasteback
With Application '<--|turn off screen & alerts only removed while testing
.ScreenUpdating = False
.EnableEvents = False
End With
i = 1 'Set the counter for result paste back
'Student numbers in cells B3:B136 WARNING SET TO 2 STUDENTS ONLY FOR TEST
'NOTE that st Nums are in col B with a duplicate in col A to collect results.
Set rRng = wbmaster.Sheets("studentlist").Range("B3:B4")
ActiveSheet.DisplayPageBreaks = False '< | turn off page breaks for speed
For Each rCell In rRng '< | loop through "students" range
ActiveSheet.DisplayPageBreaks = False '< | turn off page breaks for speed
'now open Student exam workbook and set to name "wbtarget"
Workbooks.Open ("/Users/michael/Final_V1/" & rCell.Value & ".xlsx")
Set wbtarget = Workbooks(rCell.Value & ".xlsx")
'do copy & paste from Master to Target
'PGCodeRider CHANGED!!!!!!!!!!!!!!
wbtarget.Sheets("ANSWERS").Range("h1:z160").Value = _
wbmaster.Sheets("Answers_Source").Range("h1:z160").Value
Application.CutCopyMode = False 'Clear the copy command
'Now collect the result in cell I4 and paste it back into column B using the rCell
'for that student number matches the st num in col A
'PGCodeRider CHANGED!!!!!!!!!!!!!!
wbmaster.Sheets("studentlist").Range("B" & 2 + i).Value = _
wbtarget.Sheets("Answers").Range("I4").Value
Application.CutCopyMode = False 'Clear the copy command
'now save and close the student file...
wbtarget.Close (True)
i = i + 1 'increment i for next pasteback
Next rCell '< | next student number
'save the results file
wbmaster.Save
ActiveSheet.DisplayPageBreaks = True '< | turn back on page breaks once all done
'turn screen & alerts back on
With Application
.ScreenUpdating = True: .DisplayAlerts = True
'.DisplayPageBreaks = True
End With
End Sub
Sub timerMACRO()
'Run this if you want to run your macro and then get a timed result
Dim beginTime As Date: beginTime = Now
Call Examnew_NEW
MsgBox DateDiff("S", beginTime, Now) & " seconds."
End Sub
Try removing these With which anyway make no sense in the context.
'do copy from reference "Answers_Source" worksheet
wb.Sheets("Answers_Source").Range("h1:z160").Copy
'now paste the formulas into the student exam workbook
wb2.Sheets("Answers").Range("h1:z160").Paste
Try going to visual basic editor -> tools -> reference. Check the reference that you are using and see if you active all the reference you need. The root cause of this appears to be related to problems mentioned in https://support.microsoft.com/en-ph/help/3025036/cannot-insert-object-error-in-an-activex-custom-office-solution-after and https://blogs.technet.microsoft.com/the_microsoft_excel_support_team_blog/2014/12/
Related
I'm copying values as part of one sub process and pasting value through an update button on userform.
To copy values:
Private Sub Month1_Click()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Dim wkb As Workbook
Dim wks As Worksheet
Set wkb = Workbooks.Open("Place on drive")
Set wks = wkb.Sheets("Training1")
wks.Range("Start:Finish").Copy
wkb.Close
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.ScreenUpdating = True
End Sub
To paste values in current sheet:
Private Sub UpdateActuals_Click()
For i = 1 To 12
If Me.Controls("Month" & i).Value = True Then
ThisWorkbook.Sheets("2017 Actuals").Range(i+1, 5).PasteSpecial xlPasteValues
End If
Next i
End Sub
If I replace "i+1, 5" with "B5", it errors with
"PasteSpecial method of Range class failed".
I feel as if values copied in one sub process are not brought to second one, would that be correct?
Also, how do I reduce processing time given that I have 12 months (12 files) in various places that I can't change the location for...
Range usually likes a starting cell and an ending cell. I suggest since you are looking at just one cell that you change .Range to .Cells. If you really want to use a range with RC format, .Range(Cells(row1, col1), Cells(row2, col2)), if you want just one cell then you can make the two parts the same. I have run into problems before using Range and only one cell definition before, either make it .Cells for your target or fill out Range the way I have explained.. Cheers.
Dim 2017actWS AS Worksheet
Set 2017actWS = ThisWorkbook.Worksheets("2017 Actuals")
1)
2017actWS.Cells(i+1, 5).PasteSpecial xlPasteValues
-or-
2)
2017actWS.Range(2017actWS.Cells(i+1, 5), 2017actWS.Cells(i+1,5)).PasteSpecial xlPasteValues
When using Ranges excel will often throw errors if they are not the same size in a copy and paste, you can eliminate that by using a single cell as the starting target of your paste with .Cells
Also I don't see you call your function. You will want your paste close to your copy or you might find things get strange (suggestion: just after your copy).
Edited to be sure there is not worksheeet ambiguity. Thank you Scott C.
Cheers, WWC
I'm currently looking for a code to improve my Dashboard. Actually, I need to know how to simplify and make my code more efficient. It's working but It's longer and longer day after day because of the amount of data/traffic at certain hours on the company network.
I know it's not correct to use "Select" but I didn't find an answer to my problem.
Situation:
I created my layout on SAP, and I export them (default file name is
'Export.xls')
I go to my Main Excel File (called 'Dashboard') and I
run the code from the WS concerned by the layout exported
The username need to be captured in case I'm out of office, and someone else need to run the code.
When Data are imported from SAP Export to my main file, it closes the SAP "Export" file
This is my current code:
Sub PasteSAP()
'
' Pull Data From SAP Export - Excel File
'
Dim UserName As String
UserName = Environ("username")
'Clear "PasteSAP" sheet in case the next one will have less data
Range("A:O").Select
Selection.ClearContents
'Open SAP Excel file (the export)
Workbooks.Open "C:\Users\" & UserName & "\Desktop\export.XLSX"
Windows("export.XLSX").Activate
'Copy data of the SAP Excel file
Range("A:O").Select
Selection.Copy
'Go back to the main file and paste in the active worksheet
Windows("Dashboard - 2017.xlsm").Activate
Range("A:O").Select
ActiveSheet.Paste
'Close SAP Excel file
Windows("export.XLSX").Activate
Application.DisplayAlerts = False
ActiveWindow.Close
'Change Format
Range("A:A").Select 'specify the range which suits your purpose
With Selection
Selection.NumberFormat = "General"
.Value = .Value
End With
Dim wks As Worksheet
Dim lastRow As Long
Dim r As Long
Set wks = ActiveSheet
lastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For r = 2 To lastRow
If wks.Cells(r, 1) <> "" Then
wks.Cells(r, 7).NumberFormat = "General"
wks.Cells(r, 9).Style = "Currency"
End If
Next r
Range("A1").Select
End Sub
Since you are copying the whole columns you do not Need to erase them beforehand.
Usually you would not want to jump between windows since it takes lots of time.
Also turning off ScreenUpdating could speed things up.
Try the following code:
...
Application.ScreenUpdating = False
dim wb_export as Workbook
dim ws_export_from as Worksheet, ws_export_to as Worksheet
Set wb_export = Workbooks.open("...\Export.xls")
Set ws_export_from = wb_export.Worksheets("your worksheet")
Set ws_export_to = Worksheets("Destination worksheet")
ws_export_from.range("A:O").Copy Destination := ws_export_to.Range("A:O")
wb_export.close false
set wb_export = Nothing
set ws_export_from = Nothing
set ws_export_to = Nothing
Application.ScreenUpdating = True
This should run a lot faster.
I have a code that goes through .xlsx , .xls, and .csv files(many files). But the .csv file data are usually all in column A separated by "|". How can I delimit these files first before looping through them and pulling an extract? It can be complicated because sometimes not only Col A has data but Col B may have a few rows.
EDIT~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub ColumnHeaders()
'includes filling down
'Skips unreadable files
Dim wb As Workbook, fileNames As Object, errCheck As Boolean
Dim wsReport As Excel.Worksheet
Set wsReport = ActiveWorkbook.Sheets("Sheet1") 'Whatever sheet you want to write to
Dim lRow As Long
lRow = 1
' Turn off screen updating and automatic calculation
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then
Exit Sub
End If
'''
For Each Key In fileNames 'loop through the dictionary
On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
Set wb = Nothing ' or set a boolean error flag
End If
On Error GoTo 0 ' or your custom error handler
If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key)
Else
Debug.Print "Successfully loaded " & fileNames(Key)
wb.Application.Visible = False 'make it not visible
'--------------------DATA Extraction ----------------------------------------
Dim iIndex As Integer
Dim lCol As Long
Dim lOutputCol As Long
'Loop through the worksheets in the current workbook.
For iIndex = 1 To wb.Worksheets.Count
'Set the current worksheet
Set ws = Application.Worksheets(iIndex)
'List out the workbook and worksheet names
wsReport.Range("A" & lRow).Value = wb.Name
wsReport.Range("B" & lRow).Value = ws.Name
'Start a counter of the columns that we are writing to
lOutputCol = 3
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.Count
'Write the header
wsReport.Range(Col_Letter(lOutputCol) & lRow).Value = ws.Range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
Next lCol
'Increment the row we are writing to
lRow = lRow + 1
Next iIndex
'-----------------------Data Extraction END-------------------------------------
wb.Close savechanges:=False 'close the workbook do not save
Set wb = Nothing 'release the object
End If
Next 'End of the fileNames loop
Set fileNames = Nothing
' Reset system settings
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.Visible = True
End With
End Sub
Two possible approaches.
APPROACH #1
Your code first opens the file as text, then prepends (inserts as the first line) to the file this:
sep=|
Next, your code then opens as CSV in Excel. If your text qualifiers are normal quotes, this will work surprisingly well.
I know that prepending is a little tricky in VBA. If the file is not too big, then you would create a new file with that first line followed by the rest of the original file (e.g. http://www.ozgrid.com/forum/showthread.php?t=163510).
The advantage of this approach is that your VBA doesn't need to do text-to-columns, etc.
APPROACH #2
The VBA loops through all rows and columns to clean up first before performing text-to-columns. As you said, if the delimiter is non-standard, you often end up with values in column B or C or even more so you need "clean up" first by putting them all back into column A.
I used to run my own little macro to do this cleaning up for exactly this reason i.e. "|" as a delimiter.
Later, I discovered that I could insert "sep=|" (e.g. using Notepad++) before opening in Excel.
I wrote a short article on both approaches and offered my code here: https://wildwoollytech.wordpress.com/2015/12/11/combine-excel-cells-into-one/
I want to copy data from each tab in a spreadsheet and save it as new workbooks. The original workbook has many tabs (approx 50) and one of these tabs set up for the macro to run data from, as there may be new tabs added in the future. The macro data tab contains the file location for each new workbook, the name of the tab and also some information used by another macro to e-mail these newly created workbooks to relevant parties.
The issue is getting the macro to recognize the tab names for finding the range to copy, as the tab names are listed in a cell. I am unsure if it is possible to use this list, or whether I add a sheet at the end to loop through all the sheets from a specified start location until that one with an if.
Sub Datacopy()
Dim ws As Worksheet
With Application
.ScreenUpdating = False
End With
Application.DisplayAlerts = False
Set ws = Sheets("email")
For Each Cell In ws.Columns("B").Cells
Dim file1 As String
file1 = Cell.Offset(0, 3).Text
Sheets("cell.value").Range("A1:L500").Copy
Workbooks.Add.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteAllUsingSourceTheme)
Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteComments)
ActiveWorkbook.SaveAs Filename:=file1
ActiveWorkbook.Close
Next Cell
Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
End With
MsgBox ("Finished making files!")
End Sub
Something like this should work for you. Note the following:
Code assumes that on sheet "email" it has a header row which is row 1 and the actual data starts on row 2.
It checks to see if the B column cell is a valid worksheet name in the workbook
I have verified that this code works properly and as intended based on your original post:
Sub Datacopy()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsTemp As Worksheet
Dim rSheetNames As Range
Dim rSheet As Range
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("email")
Set rSheetNames = wsData.Range("B2", wsData.Cells(Rows.Count, "B").End(xlUp))
If rSheetNames.Row < 2 Then Exit Sub 'No data
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each rSheet In rSheetNames
If Not Evaluate("ISERROR('" & rSheet.Text & "'!A1)") Then
Set wsTemp = Sheets.Add
Sheets(rSheet.Text).Range("A1:L500").Copy
wsTemp.Range("A1").PasteSpecial xlPasteAllUsingSourceTheme
wsTemp.Range("A1").PasteSpecial xlPasteComments
wsTemp.Move
ActiveWorkbook.SaveAs rSheet.Offset(, 3).Text
ActiveWorkbook.Close False
End If
Next rSheet
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox "Finished making files!"
End Sub
I am trying to loop through some columns in a row and create new worksheets with the name of the value of the current column/row that I am in.
Sub test()
Range("R5").Select
Do Until IsEmpty(ActiveCell)
Sheets.Add.Name = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Loop
End Sub
This code creates the first one correctly starting at R5 but then it appears that the macro switches to that worksheet and doesn't complete the task.
The Sheets.Add automatically moves your selection to the newly created sheet (just like if you insert a new sheet by hand). In consequence the Offset is based on cell A1 of the new sheet which now has become your selection - you select an empty cell (as the sheet is empty) and the loop terminates.
Sub test()
Dim MyNames As Range, MyNewSheet As Range
Set MyNames = Range("R5").CurrentRegion ' load contigeous range into variable
For Each MyNewSheet In MyNames.Cells ' loop through cell children of range variable
Sheets.Add.Name = MyNewSheet.Value
Next MyNewSheet
MyNames.Worksheet.Select ' move selection to original sheet
End Sub
This will work better .... you assign the list of names to an object variable of type Range and work this off in a For Each loop. After you finish you put your Selection back to where you came from.
Sheets.Add will automatically make your new sheet the active sheet. Your best bet is to declare variables to your objects (this is always best practice) and reference them. See like I've done below:
Sub test()
Dim wks As Worksheet
Set wks = Sheets("sheet1")
With wks
Dim rng As Range
Set rng = .Range("R5")
Do Until IsEmpty(rng)
Sheets.Add.Name = rng.Value
Set rng = rng.Offset(0, 1)
Loop
End With
End Sub
Error handling should always be used when naming sheets from a list to handle
invalid characters in sheet names
sheet names that are too long
duplicate sheet names
Pls change Sheets("Title") to match the sheet name (or position) of your title sheet
The code below uses a variant array rather than a range for the sheet name for performance reasons, although turning off ScreenUpdating is likely to make the biggest difference to the user
Sub SheetAdd()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim strError As String
Dim vArr()
Dim lngCnt As Long
Dim lngCalc As Long
Set ws1 = Sheets("Title")
vArr = ws1.Range(ws1.[r5], ws1.[r5].End(xltoRight))
If UBound(vArr) = Rows.Count - 5 Then
MsgBox "sheet range for titles appears to be empty"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
End With
For lngCnt = 1 To UBound(vArr)
Set ws2 = Sheets.Add
On Error Resume Next
ws2.Name = vArr(lngCnt, 1)
If Err.Number <> 0 Then strError = strError & vArr(lngCnt, 1) & vbNewLine
On Error GoTo 0
Next lngCnt
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With
If Len(strError) > 0 Then MsgBox strError, vbCritical, "These potential sheet names were invalid"
End Sub
This is probably the simplest. No error-handling, just a one-time code to create sheets
Sub test()
Workbooks("Book1").Sheets("Sheet1").Range("A1").Activate
Do Until IsEmpty(ActiveCell)
Sheets.Add.Name = ActiveCell.Value
Workbooks("Book1").Sheets("Sheet1").Select
ActiveCell.Offset(0, 1).Select
Loop
End Sub