My VBA code is set to copy a value from one sheet (NB this value will change each time the sheet is open) and paste into a 'database' on the next available row.
Think I've got it right but the Paste method seems to fail, can anyone see why?
Windows("Invoice Program.xlsm").Activate
Range("B4").Select
Application.CutCopyMode = False
Selection.Copy
Workbooks.Open ("C:\Users\Invoice Database.xlsx")
Windows("Invoice Database.xlsx").Activate
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.Paste
Dim varTemp as Variant
Windows("Invoice Program.xlsm").Activate
Range("B4").Select
varTemp = ActiveCell.Value
Workbooks.Open ("C:\Users\Invoice Database.xlsx")
Windows("Invoice Database.xlsx").Activate
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveCell = varTemp
Use ActiveSheet.Paste but in the line before use DoEvents.
DoEvents
ActiveSheet.Paste
Related
Newbie here! I have an action which I'd like to repeat, for specific workbooks or specific worksheets.
Is there a way to do it without copy and pasting the whole code for the 2nd, 3rd etc worksheets?
Only the workbook and the worksheet names change. other actions (e.g. copy paste) remains the same.
Although there's a "For Each loop", but I don't know how to do it in a way that allows me to specify which worksheets exactly.
For example, I'm
Step 1: copying data from workbook "Red" sheet "Apple". paste into output
workbook.
Repeat action. Step 2: copying data from workbook "Yellow" sheet "Banana". paste into
same output workbook.
Here's my code if anyone could kindly advise. VBA newbie here thank you!
Sub CopyPastefromOtherWB()
Range("B13").Select
'Activate WB1
Workbooks.Open Filename:= "C:\Users\Desktop\My macro projects\Red"
Worksheets("Apple").Activate
Range("A1").Select
Do While Selection.Value <> "Mar"
ActiveCell.Offset(0, 1).Select
Loop
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Selection.Copy
'Activate output notebook
Workbooks.Open Filename:= "C:\Users\Desktop\My macro projects\OutputWB"
Worksheets("Sheet1").Activate
Range("B13").PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'HERE IS WHERE THE REPEAT HAPPENS. Activate WB2
Workbooks.Open Filename:= "C:\Users\Desktop\My macro projects\Yellow"
Worksheets("Banana").Activate
Range("A1").Select
Do While Selection.Value <> "Mar"
ActiveCell.Offset(0, 1).Select
Loop
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Selection.Copy
'Activate output notebook
Workbooks.Open Filename:= "C:\Users\Desktop\My macro projects\OutputWB"
Worksheets("Sheet1").Activate
Range("C13").PasteSpecial paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveCell.Offset(0, 1).Select
End Sub
Please see How to avoid using Select in Excel VBA.
Sub CopyPastefromOtherWB(ByVal FromPath As String, ByVal FromSheetName As String, ByVal TargetCell As Range)
With Workbooks.Open(FromPath)
With .Worksheets(FromSheetName)
Dim c As Range
Set c = .Rows(1).Find("Mar", LookAt:=xlWhole).Offset(1, 0)
TargetCell.Resize(c.Rows.Count, 1).Value = .Range(c, c.End(xlDown)).Value
End With
.Close False
End With
End Sub
With Workbooks.Open("C:\Users\Desktop\My macro projects\OutputWB").Worksheets("Sheet1")
CopyPastefromOtherWB "C:\Users\Desktop\My macro projects\Red", "Apple", .Range("B13")
CopyPastefromOtherWB "C:\Users\Desktop\My macro projects\Yellow", "Banana", .Range("C13")
End With
After months of learning, I developed a solution, feel free to use the code below and tweak it to your needs. This solution is for a set area of cells.
Sub copypaste_adhoc()
Dim inputfile As Workbook
Set inputfile = Workbooks.Open("c:\path\workbook")
Dim arrSht, i
arrSht = Array("worksheet1", "worksheet2")
For i = LBound(arrSht) To UBound(arrSht)
With Worksheets(arrSht(i))
.Range("A31:Z31").Copy
ThisWorkbook.Sheets("Sheet1").Cells(Sheet5.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
Next i
Application.CutCopyMode = False
Sheet5.Range("a1").CurrentRegion.EntireColumn.AutoFit
End Sub
I have an Excel macro that uses a function. Currently, the file is on a network drive. Data is pasted to the Excel file (new tab each time) and the macro is run with no problems (account number successfully pulled from larger data set).
In my effort to move the macro from a network drive to the cloud and run the macro from a separate Excel file (the file that contains the initial data dump i.e. no pasting data to file where macro lives), the portion of the macro that uses the function is now returning #NAME? instead of the proper numerical values. I am totally stumped as to why this is happening.
Literally any help at all is appreciated!
Function
Function onlynumbers(ByVal ref As String)
Dim rx As Object
Set rx = CreateObject("VBScript.RegExp")
With rx
.Pattern = "\D"
.Global = True
onlynumbers = .Replace(ref, "")
End With
End Function
Macro (see 'Fix Account Number' section)
Sub FORMAT()
'Remove extra rows on TOP
Rows("1:6").Select
Selection.Delete Shift:=xlUp
'Remove Extra Columns
Columns("A:H").Select
Selection.Delete Shift:=xlToLeft
Columns("B:O").Select
Selection.Delete Shift:=xlToLeft
Columns("C:J").Select
Selection.Delete Shift:=xlToLeft
'Extract Account Number from OBI Field
Range("C2").Select
ActiveCell.Formula = "=MID(B2,SEARCH(""79*"",B2),8)"
'Autofill Formula
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("C2").AutoFill Destination:=Range("C2:C" & lastRow)
'Fix Account Number
Range("D2").Select
ActiveCell.Formula = "=onlynumbers(C2)"
Range("D2").AutoFill Destination:=Range("D2:D" & lastRow)
Range("E2").Select
ActiveCell.Formula = "=IF(LEN(D2)<6,"""",D2)"
Range("E2").AutoFill Destination:=Range("E2:E" & lastRow)
Range("E2:E" & lastRow).Select
Selection.Copy
Range("B2:B" & lastRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("C:D").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
'Column Headers
Range("A1:G1").Value = Array("Amount", "Account", "Transaction Type", "Description", "Cash Type", "Post Date", "Tax Year")
'Switch Amount and Account Columns
Columns("B:B").Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
'Set Transaction Type
Range("C2").Value = "Deposit to Account - Wire received"
Range("C2").AutoFill Destination:=Range("C2:C" & lastRow)
'Set Description
Range("D2").Value = "$TranDesc$ of $CashAmount$"
Range("D2").AutoFill Destination:=Range("D2:D" & lastRow)
'Set Cash Type
Range("E2").Value = "Principal"
Range("E2").AutoFill Destination:=Range("E2:E" & lastRow)
'Set Post Date
Range("F2").Select
ActiveCell.Formula = "=TODAY()"
Range("F2").AutoFill Destination:=Range("F2:F" & lastRow)
'Set Tax Year
Range("G2").Select
ActiveCell.Formula = "=YEAR(TODAY())"
Range("G2").AutoFill Destination:=Range("G2:G" & lastRow)
'Final Formatting
Range("C1:G1").Select
Selection.Font.Bold = True
Columns("C:G").Select
Columns("C:G").EntireColumn.AutoFit
'Reset Selection
Range("A1").Select
End Sub
Did you also move your function, or just the macro?
If not, putting the function in the same place as the macro (just after End Sub on a new line) should fix things if you need the macro to refer to the function.
However, to use the function in a worksheet (which it looks like you are doing), the workbook containing the cell with the fixed account number needs to also contain the function. That way, the account number cell can use the function.
The error NAME is because the cell formula cannot find a defined name onlynumbers.
You could also try defining the function with the Name Manager instead of in VBA, but the best way might be to just change the formula in that cell to do what you want it to do using the built-in Excel functions. You could then update the macro to input this new formula at that line.
Can someone please let me know why my code is not pasting anything from my source data to my destination file?
The objectives of this code are to select rows that satisfy certain criteria, copy-pastes it into another workbook, The code is shown below:
Sub Copy_Source_LRE()
Dim LastRow As Integer, i As Integer, erow As Integer
Workbooks.Open _
"C:\Users\sjiang\OneDrive - Canada Pension Plan Investment Board\Desktop\IOA Exposure\AAPAF_strategy_loadings_2019-04-01_2020-04-01 (2).csv"
Worksheets("AAPAF_strategy_loadings_2019-04").Activate
Set sht = ActiveSheet
'Workbooks("AAPAF_strategy_loadings_2019-04-01_2020-04-01 (2).csv").Sheets("AAPAF_strategy_loadings_2019-04").Activate
LastRow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
For i = 2 To LastRow
For Each d In Array("4/1/2019", "5/1/2019", "6/3/2019", "7/1/2019", "8/1/2019", "9/2/2019", _
"10/1/2019", "11/1/2019", "12/2/2019", "1/2/2020", "2/3/2020", "3/2/2020")
If Cells(i, 2) = d And Cells(i, 3) = "Real Estate" And Cells(i, 4) = "Listed Real Estate" And Cells(i, 5) = "AAPAF_SA" Then
Range(Cells(i, 2), Cells(i, 12)).Select
Selection.Copy
Workbooks.Open _
"C:\Users\sjiang\OneDrive - Canada Pension Plan Investment Board\Desktop\IOA Exposure\pull data.xlsm"
Worksheets("Sheet1").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
'ActiveWorkbook.Close
End If
Next d
Next i
Application.CutCopyMode = False
End Sub
This is a really easy and basic way that I use all the time to copy data into new workbooks. In this example I'm copying a named range called "MasterData" into a new blank workbook. Then I save that new book with a password and re-activate the current workbook.
Dim newfilename As String
newfilename = "/Users/" & userName & "/Desktop/savedWorkbook.xlsx"
Dim NewBook As Workbook
Set NewBook = Workbooks.Add
ThisWorkbook.Activate
Sheets("Datasheet").Select
Range("MasterData").Copy
NewBook.Activate
NewBook.Sheets(1).Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
NewBook.SaveAs Filename:=newfilename, Password:="examplepassword", AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
NewBook.Close (True)
ThisWorkbook.Activate
I've redone the code for you as the major problem was related to a loop that is not really necessary. The best/fast way to apply those criteria and extract the data is using a filter to apply them, so copy the visible cells without the hidden (unmatching) lines and then open the second file where you need to past info, find next blank line below selection and paste all lines at once.
I'm pasting the code below (with comments) and also saved a zip file with 3 files (code, info, database) that might reflect your working files, link below.
VBS code:
Sub Copy_Source_LRE()
Dim LastRow As Integer, i As Integer, erow As Integer
Workbooks.Open ThisWorkbook.Path & "\" & "Wks1.xlsx" 'change the path and name here
Worksheets(1).Activate
Set sht = ActiveSheet
LastRow = Range("a1").SpecialCells(xlCellTypeLastCell).Row
datar = Range(Cells(LastRow, 12), Cells(1, 1)).Address 'data range
Range(datar).Select
Selection.AutoFilter 'create a filter,then use the criteria you need
ActiveSheet.Range(datar).AutoFilter Field:=2, Criteria1:= _
Array("4/1/2019", "5/1/2019", "6/3/2019", "7/1/2019", "8/1/2019", "9/2/2019", _
"10/1/2019", "11/1/2019", "12/2/2019", "1/2/2020", "2/3/2020", "3/2/2020"), Operator:=xlFilterValues 'your dates array can be update here
ActiveSheet.Range(datar).AutoFilter Field:=3, Criteria1:="Real Estate", Operator:=xlAnd
ActiveSheet.Range(datar).AutoFilter Field:=4, Criteria1:="Listed Real Estate", Operator:=xlAnd
ActiveSheet.Range(datar).AutoFilter Field:=5, Criteria1:="AAPAF_SA", Operator:=xlAnd
Range(datar).Offset(1, 0).Resize(Range(datar).Rows.Count - 1, Range(datar).Columns.Count).Select 'resize selection to remove the header
Selection.SpecialCells(xlCellTypeVisible).Select 'select visible cells only
Selection.Copy
Workbooks.Open ThisWorkbook.Path & "\" & "Wks2.xlsx" 'change the path and name here
Worksheets("Sheet1").Select
Range("A1").End(xlDown).Offset(1, 0).Select 'goes to the last row on column A the goes another one - 1st empty
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close SaveChanges:=True 'close and save your database
Application.CutCopyMode = False
ActiveWorkbook.Close SaveChanges:=False 'close without saving your csv file
End Sub
link to files/code: https://drive.google.com/file/d/1zL_TwclHR4lrNhKB1xODGAmliPHM1r3K/view?usp=sharing
If the solution matches you need please consider as solution. Regards!
So I'm trying to figure out how I can setup a macro that will take the data that I enter into a form on one sheet then log it into a log in another sheet. It will log it but my big problem is that it needs to go to the next line and I can't quite figure out the code for it. Here is what my code looks like:
Sub Appt()
'
' Appt Macro
'
'
Range("E4").Select
Selection.Copy
Sheets("Appointments").Select
Range("G7").Select
ActiveSheet.Paste
Sheets("Data Entry").Select
Range("E6").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Appointments").Select
Range("D7").Select
ActiveSheet.Paste
Sheets("Data Entry").Select
Range("E8").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Appointments").Select
Range("E7").Select
ActiveSheet.Paste
Sheets("Data Entry").Select
Range("E10").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Appointments").Select
Range("F7").Select
ActiveSheet.Paste
Sheets("Data Entry").Select
Range("E12").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Appointments").Select
Range("H7").Select
ActiveSheet.Paste
Sheets("Data Entry").Select
Range("E4").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("E6").Select
Selection.ClearContents
Range("E8").Select
Selection.ClearContents
Range("E10").Select
Selection.ClearContents
Range("E12").Select
Selection.ClearContents
End Sub
To get the next empty row on Sheets("Appointments") you would use this formula to get the row number:
tRw = Sheets("Appointments").Range("D" & Rows.count).End(xlUp).Offset(1).Row
This assumes that there is nothing in column D below what you are pasting.
It is apparent that you used the macro recorder, and this is a great way to learn. But using the .select so much will slow things down and is unneeded.
To get around that declare the sheets as variables and then one line for each copy paste is needed.
Sub APPT()
Dim oWs As Worksheet
Dim tWs As Worksheet
Dim tRw As Long
Set oWs = Sheets("Data Entry")
Set tWs = Sheets("Appointments")
tRw = tWs.Range("D" & Rows.count).End(xlUp).Offset(1).Row
With oWs
.Range("E4").copy tWs.Range("G" & tRw)
.Range("E6").copy tWs.Range("D" & tRw)
.Range("E8").copy tWs.Range("E" & tRw)
.Range("E10").copy tWs.Range("F" & tRw)
.Range("E12").copy tWs.Range("H" & tRw)
.Range("E4").ClearContents
.Range("E6").ClearContents
.Range("E8").ClearContents
.Range("E10").ClearContents
.Range("E12").ClearContents
End With
End Sub
For other methods of finding the next row look at Siddharth Rout's answer here.
And as BruceWayne stated in his comment, this is a great reference as to why/how to avoid using .select
It's best to avoid the user's clipboard and to assign the values directly:
Sub Appt()
Dim n&, v
v = [transpose(offset('data entry'!e4,{0;2;4;6;8},))]
With Sheets("appointments")
n = .Range("d" & .Rows.Count).End(xlUp).Row
.[g1].Offset(n) = v(1)
.[d1].Offset(n) = v(2)
.[e1].Offset(n) = v(3)
.[f1].Offset(n) = v(4)
.[h1].Offset(n) = v(5)
End With
Sheets("data entry").Range("e4,e6,e8,e10,e12").ClearContents
End Sub
I have an issue with the following code.
I want each cell with the value "long" in the column "U" to be copied in a new sheet.
But the code I developed only retrieves the first result. It does stop after "U6".
Can you please help me?
Sub reportcrea ()
Worksheets("TLM").Select
ActiveSheet.Range("U3").Select
Do
If ActiveCell.Value = "long" Then
ActiveCell.EntireRow.Select
Selection.Copy
Sheets("report").Select
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell.Offset(1, 0))
End sub ()
I found a bug in your code in this line:
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Offset takes two parameters, so it should be something like this:
Range("A" & Rows.Count).End(xlUp).Offset(1,0).Select
Also, you should cancel CutCopy mode right after you paste what is in the clipboard:
ActiveSheet.Paste 'Paste is done here
Application.CutCopyMode = False 'This is a good practice
See if that helps. Also, a screenshot of the TLM sheet would help us analyze the problem more accurately.
First up, End Sub shouldn't have trailing brackets. When I copied it into a module it highlighted an error straight away.
Your loop is using ActiveCell.Offset(1, 0).Select twice:
If ActiveCell.Value = "long" Then
ActiveCell.EntireRow.Select
Selection.Copy
ActiveCell.Offset(1, 0).Select 'first Offset
Sheets("report").Select
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("TLM").Select
ActiveCell.Offset(1, 0).Select 'second Offset
Else
so you're only looking at every second row after each "long" is found.
I tested your code on 10 contoguous "long" cells and got 5 back in the report sheet. I couldn't reproduce your U6 stop.