I am writing a copy to last row code that seems to copy the same exact number of rows each time.
The code is to open up a new workbook, take a specific sheet from the new workbook, copy all the available data, and pasting it into the original workbook. My code is below
Dim wkb As Workbook
Dim wkbFrom As Workbook
Dim wks As Worksheet
Dim path As String, FilePart As String
Dim TheFile
Dim loc As String
Dim Lastrow As Long
Dim lr As Long
Dim lr2 As Long
FilePart = Trim(shPivot.Range("E17").Value)
TheFile = Dir(path & "*" & FilePart & ".xls")
Set wkbFrom = Workbooks.Open(loc & path & TheFile & FilePart)
Set wks = wkbFrom.Sheets(shPivot.Range("E15").Value)
Lastrow = ActiveSheet.UsedRange.Rows.Count
lr = shCurrentWeek.Range("A" & Rows.Count).End(xlUp).Row
lr2 = wks.Range("A" & Rows.Count).End(xlUp).Row
Debug.Print lr
Debug.Print lr2
'Copies range from report generated to share drive and pastes into the current week tab of open order report
wks.Range("A2:N" & lr2).Copy wkb.Sheets("Current Week").Range("A4")
'Closes the workbook in the shared drive
wkbFrom.Close False
I am constantly getting 187 rows of data even if the "new opened Workbook" has only 167. And data fills in column "A" all the way to row 507. Help?!
I've had trouble getting the last row of data myself from some worksheets; here is code that I use now that seems to be most consistent for me.
objExcelWks.Range("A1").Offset(objExcelWks.Rows.Count - 1, 0).End(xlUp).Row
Maybe that will work?
Related
I am a trainee in a company and basically became tech support (better than coffee maker though)
And so i'm trying to get one closed workbook to copy data into an open one
So far this is the code i've got but i've some troubles with the if statement
Sub allergo()
Dim lastRow As Long
Dim bkBk1 As Workbook, wkBk2 As Workbook
Dim wkSht As Object
Dim mnt As String
lr = wkBk2.Sheets(1).Range("R" & Rows.Count).End(xlUp).Row
mnt = InputBox("Enter Filename")
Set wkBk1 = ActiveWorkbook
Set wkBk2 = Workbooks.Open("Documents\" & mnt & ".xlsx")
For Each cell In wkBk1.Sheets(1).Range(wkBk1.Sheets(1).Cells(2, "R"), wkBk1.Sheets(1).Cells(lr, "R"))
wkBk1.Sheets(1).Range("R1:R" & lr).Value = wkBk2.Sheets(1).Range("R1:R" & lastRow).Value
wkBk2.Close
End Sub
Basically I've got two files that have the same columns but between some weeks rows disapear or appear as each row is a purchase order with a specific number and in row R we add comments and i want the comments in column R to copy to the new work book on the row where there's the same purchase order number. While some comments are attached to purchase orders that are not in the file anymore so they are not needed and some purchase orders have moved so i can't just copy paste.
Not sure the If is a good idea as it won't compare my row E 146 with all the others of the new work book and thus only test E146 closed workbook = E146 newworkbook while it should test E146 closed = E147/E148 etc..
This is the closed workbook:
This is the new workbook:
Thanks for the help !
Maybe a VLOOKUP is possible for this kind of things i'm not sure ..
Sub strilltrying()
Dim ws As Worksheet
Set ws = Sheets("Sheet 1")
Dim lr As Long
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
Cells(lr, "R").Formula = "=VLOOKUP(E2,'H:\Documents\[OPEN ORDERS 16.07.2018.xlsx]Sheet 1'!$E:$R,14)"
End Sub
This is the vlookup formula that works but not fully as i've to take two different variables.. I found that index + match can do it but i'm having a hard time figuring it out.
I'd need an index formula that compares column E and column J in the way of the vlookup.
Sub allergo()
Dim lastRow As Long
Dim bkBk1 As Workbook, wkBk2 As Workbook
Dim wkSht As Object
Dim mnt As String
lr = wkBk2.Sheets(1).Range("R" & Rows.Count).End(xlUp).Row
mnt = InputBox("Enter Filename")
Set wkBk1 = ActiveWorkbook
Set wkBk2 = Workbooks.Open("Documents\" & mnt & ".xlsx")
For Each cell In wkBk1.Sheets(1).Range(wkBk1.Sheets(1).Cells(2, "R"), wkBk1.Sheets(1).Cells(lr, "R"))
if cell = "" then 'add your clause here
wkBk1.Sheets(1).Range("R1:R" & lr).Value = wkBk2.Sheets(1).Range("R1:R" & lastRow).Value
end if
next cell
wkBk2.Close
End Sub
Your requirements are not entirely clear, I would avoid a loop if possible as well.
sorry if this has been asked here many times. I am a beginner in vba excel, so I only have brief idea of how to begin the code. I am using Excel 2013.
I have 2 different workbooks, main and copy.
Row 1 to 4 will be empty.
Row 5 is meant for header/labeling the information it will be providing for both workbooks.
The "main" workbook will be using columns A to DN to store all the data.
If the cell contains "X" - it will copy column A to P, to the workbook "copy". After which, it will go on to the next row to determine the same thing.
If the cell is empty, it will proceed down to the next row to determine the same thing as well.
The code has to be dynamic as new information will be added every 3 months, such as new rows added or the criteria changing from "X" to empty, or empty to "X".
This is the code I have got as of now.
It works but since there are so many columns to check through, I was advised to do another code for this.
Sub copy()
Dim lr As Long, lr2 As Long, r As Long
lr = Sheets("main").Cells(Rows.Count, "A").End(xlUp).row
lr2 = Sheets("copy").Cells(Rows.Count, "A").End(xlUp).row
For r = lr To 2 Step -1
If range("Q" & r).Value = "X" Then
Rows(r).copy Destination:=Sheets("copy").range("A" & lr2 + 1)
lr2 = Sheets("copy").Cells(Rows.Count, "A").End(xlUp).row
End If
Next r
End Sub
For that you will have to declare two workbook variables and two worksheet variables to hold the source and destination workbooks and worksheets reference in the code.
Tweak the following code as per your requirement.
I have added the comments in the code which will help you to understand the flow of the program.
Further, more error handling can be used to make sure the source and destination sheets are found in source and destination workbook respectively.
If required, you can add the error handling as well.
Option Explicit
Sub CopyDatoToAnotherWorkbook()
Dim srcWB As Workbook, destWB As Workbook 'Variables to hold the source and destination workbook
Dim srcWS As Worksheet, destWS As Worksheet 'Variables to hold the source and destination worksheets
Dim FilePath As String 'Variable to hold the full path of the destination workbook including it's name with extension
Dim lr As Long, lr2 As Long, r As Long
Application.ScreenUpdating = False
Set srcWB = ThisWorkbook 'Setting the source workbook
Set srcWS = srcWB.Sheets("main") 'Setting the source worksheet
'Setting the FilePath of the destination workbook
'The below line assumes that the destination file's name is MyFile.xlsx and it is saved at your desktop. Change the path as per your requirement
FilePath = Environ("UserProfile") & "\Desktop\MyFile.xlsx"
'Cheching if the destination file exists, it yes, proceed with the code else EXIT
If Dir(FilePath) = "" Then
MsgBox "The file " & FilePath & " doesn't exist!", vbCritical, "File Not Found!"
Exit Sub
End If
'Finding the last row used in column A on source worksheet
lr = srcWS.Cells(Rows.Count, "A").End(xlUp).Row
'Opening the destination workbook and setting the source workbook
Set destWB = Workbooks.Open(FilePath)
'Setting the destination worksheet
Set destWS = destWB.Sheets("copy")
'Looping through rows on source worksheets
For r = lr To 2 Step -1
'Finding the first empty row in column A on destination worksheet
lr2 = destWS.Cells(Rows.Count, "A").End(xlUp).Row + 1
If srcWS.Range("Q" & r).Value = "X" Then
srcWS.Rows(r).copy Destination:=destWS.Range("A" & lr2 + 1)
End If
Next r
'Closing the destination workbook
destWB.Close True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
I have about 50 Excel sheets in one folder, on my MacBook - (/Users/myusername/Desktop/Tidy/folder")
I want to perform the following Macro on them all:
Sub SmartCopy()
Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long, i As Long, j As Long
Set s1 = Sheets("s1")
Set s2 = Sheets("s2")
N = s1.Cells(Rows.Count, "Y").End(xlUp).Row
j = 1
For i = 1 To N
If s1.Cells(i, "Y").Value = "No" Then
Else
s1.Cells(i, "Y").EntireRow.Copy s2.Cells(j, 1)
j = j + 1
End If
Next i
End Sub
I am struggling to get the sheets to open, almost like the filepath won't be recognised, also each sheet is named like this:
business-listing-002-w-site.csv
with one tab:
business-listing-002-w-site.csv
So I also need to either 1) rename the sheet each time 2) have the macro just open the only sheet in the workbook.
I want to copy all data from all workbooks into one master. I did try to add my Macro and adapt this one but just can't get it to run at all.
link to another post
You need to define the workbook (file), not just the sheet(tab).
Dim filePath as String
Dim sheetStart as String
Dim count as Integer
Dim sheetEnd as string
Dim thisSheet as Worksheet
Dim wb1 as Workbook
Dim ws1 as Worksheet
filePath = "/Users/myusername/Desktop/Tidy/folder/"
sheetStart = "business-listing-"
sheetEnd = "-w-site"
Set thisSheet as ThisWorkbook.Worksheets("Sheet1")
For count = 1 to 44 'the range of sheets you have
Set wb1 = Workbooks.Open(filePath & sheetStart & format(count, "000") & sheetEnd & ".csv")
Set ws1 = wb1.Worksheets(sheetStart & format(count, "000") & sheetEnd)
'move the ranges you want from ws1 to thisSheet
wb1.close
next count
each time the code loops, it will change the filename being opened and the sheet that it is looking for.
I assume you either know or can find how to copy a range from ws1 to the next available row of thisSheet based on the original code you provided.
edited with improved code based on comments
Good day, below is a sample of code i am trying to get to work. Normally this lastrow call i run works perfectly in the worksheet but when i try to use on a foreign workbook like below, it doesnt. What am i doing wrong?
thanks
Dim rngTestArea As Range
Dim i As Long
Dim j As Double
Dim MyResult As String
Dim geodis, Location As Variant
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select file")
If Ret1 = False Then Exit Sub
Set wb2 = Workbooks.Open(Ret1)
lastRow = wb2.Sheets(2).Range("C" & Rows.Count).End(xlUp).Row
I guess "it doesn't (work)" stands for "it doesn't pick the right last row index"
you have to use:
With wb2.Sheets(2)
lastRow = .Range("C" & .Rows.Count).End(xlUp).Row
End With
so that Rows.Count also refers to the wanted worksheet (Sheets(2))
I have formulas from columns O -> X and need them drag them to last row used. Below is the current code I am using:
Dim wkb As Workbook
Dim wkbFrom As Workbook
Dim wks As Worksheet
Dim rng As Range
Dim path As String, FilePart As String
Dim TheFile
Dim loc As String
Dim Lastrow As Long
Set wkb = ThisWorkbook
loc = shPivot.Range("E11").Value
path = shPivot.Range("E12").Value
FilePart = Trim(shPivot.Range("E13").Value)
TheFile = Dir(path & "*" & FilePart & ".xls")
Set wkbFrom = Workbooks.Open(loc & path & TheFile & FilePart)
Set wks = wkbFrom.Sheets("SUPPLIER_01_00028257_KIK CUSTOM")
Set rng = wks.Range("A2:N500")
'Copies range from report generated to share drive and pastes into the current week tab of open order report
rng.Copy wkb.Sheets("Current Week").Range("A4")
With ActiveSheet
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("O4:X4").AutoFill .Range("O4:X4").Resize(Lastrow)
End With
The code Lastrow is not dragging the formulas down
You can do auto-fill like this in VBA (verified using macro recording)
Range("O1:X1").Select
Selection.AutoFill Destination:=Range("O1:X25"), Type:=xlFillDefault
Now that you have this code as a base to work with you can use any variables you like in the syntax like this:
Range("O1:X1").Select
Selection.AutoFill Destination:=Range("O1:X" & Lastrow), Type:=xlFillDefault
I used this:
Sub sum_1to10_fill()
Sheets("13").Activate
Range("EG12").Copy
Range("EG12:FT36").PasteSpecial xlPasteFormulas
End sub
...and filled up my whole label both down and right.