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.
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.
How can I dynamically extend the number of rows in two columns that I need to copy to another sheet?
First, I identify the number of rows I need to include and store in totrows:
Dim totrows As Integer
With ThisWorkbook.Worksheets("Sheet1")
totrows = .Range("A" & .Rows.Count).End(xlUp).Row
End With
Next, I am trying to extend the two columns of interest ("B" and "G") so that the range includes that totrows rows. For a static example, if totrows=100 then I would have:
With ThisWorkbook.Worksheets("Sheet1")
.Range("B2:B102,G2:G102").copy
End With
I then paste them into my second sheet with:
ThisWorkbook.Worksheets("Sheet2").Range("A2").Paste
.Range("B2:B102,G2:G102").copy
can be written as
.Range("B2:B" & totrows & ",G2:G" & totrows).Copy
Another way without using .Copy or .Paste would be this:
Sub Copy()
Dim wb As Workbook
Dim wsCopy As Worksheet
Dim wsPaste As Worksheet
Dim totrows As Integer
Set wb = Workbooks("Book1.xlsm")
Set wsCopy = wb.Worksheets("Sheet1")
Set wsPaste = wb.Worksheets("Sheet2")
totrows = wsCopy.Range("A" & wsCopy.Rows.Count).End(xlUp).Row
wsPaste.Range("A1:B" & totrows) = wsCopy.Range("A2:A" & totrows, "G2:G" & totrows).Value
End Sub
This way your directly putting the Values into the Range you want.
i have 2 sheeets. basically ws1 is the destination, ws2 is the source. then i have 2 criterias, an ID Number, and a name of the person who will work on the ID Number.
source contains a row with new actions/progress done by "working person" and need to paste it on the destination in order to update it.
I've read around and saw that autofilter looks like the way to go. i have a code here that autofilters, but i'm just not sure how i can "attack" the problem.
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastrowDest As Long, currow As Long, lastrowSrc As Long
Dim critvalue1 As String
'Destination sheet (dashboard)
Set ws1 = Sheets("Destination")
'Source Sheet (source)
Set ws2 = Sheets("Source")
lastrowSrc = ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
lastrowDest = ws1.Range("A" & Rows.Count).End(xlUp).Row
For currow = 2 To lastrowSrc
critvalue1 = ws2.Range("E" & currow).Value
ws1.Range("A1").AutoFilter field:=5, Criteria1:=critvalue1
Next currow
end sub
is there an easy way to copy the row from source to destination provided that the IDnumber matches? (the IDnumber is unique)
the code above filters but i'm not sure of how to copy or move the rows.
thanks in advance.
This could be done with SUMPRODUCT or VLOOKUP but if you are set on VBA then try this
Sub copyRow()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastrowDest As Long, currowSrc As Long, currowDest As Long, lastrowSrc As Long
Dim critvalue1 As String
Set ws1 = Sheets("Sheet2")
Set ws2 = Sheets("Sheet1")
lastrowSrc = ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Row - 1
lastrowDest = ws1.Range("A" & Rows.Count).End(xlUp).Row
For currowSrc = 2 To lastrowSrc
critvalue1 = ws2.Range("E" & currowSrc).Value
ws2.Cells(6, 5).Value = critvalue1
For currowDest = 2 To lastrowDest
If ws1.Range("E" & currowDest).Value = critvalue1 Then
ws2.Rows(currowSrc).Copy Destination:=ws1.Range("A" & currowDest)
End If
Next currowDest
Next currowSrc
End Sub
I find it easier than dealing with the autofilter. It goes row by row from the source sheet and checks for a match in every row of the destination sheet. If there is a match, the source row in copied to the matching destination row.
To keep formatting instead of
ws2.Rows(currowSrc).Copy Destination:=ws1.Range("A" & currowDest)
use
ws2.Rows(currowSrc).Copy
ws1.Range("A" & currowDest).Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
I pulled this out of a larger macro I use and made some changes to make it match your method a little better and I deleted some irrelevant stuff. The variable names are a bit different. I believe this does what you need. Let me know if it gives you trouble.
Don't forget to populate the ID and Name arrays, set the value for the 2 column variables and assign the sheet names before running.
Sub copyByAutofilter()
Dim filterList1 As Variant
filterList1 = Array("ID1", "ID2")
filterCol1 = 1 'or whatever column contains the IDs
Dim filterList2 As Variant
filterList2 = Array("Name1", "Name2")
filterCol2 = 2 'or whatever column contains the names
Dim sourceWB As String
sourceWB = ThisWorkbook.Name
Dim sourceWS As String
sourceWS = "Sheet2"
Dim destinationWB As String
destinationWB = ThisWorkbook.Name
Dim destinationWS As String
destinationWS = "Sheet3"
lastrowSrc = Sheets(sourceWS).Range("A" & Rows.Count).End(xlUp).Offset(1).Row
lastrowDest = Sheets(destinationWS).Range("A" & Rows.Count).End(xlUp).Row
Workbooks(sourceWB).Sheets(sourceWS).AutoFilterMode = False
Workbooks(sourceWB).Sheets(sourceWS).Range("$A$1:$O" & lastrowSrc).AutoFilter Field:=filterCol1, _
Criteria1:=filterList1, Operator:=xlFilterValues
Workbooks(sourceWB).Sheets(sourceWS).Range("$A$1:$O" & lastrowSrc).AutoFilter Field:=filterCol2, _
Criteria1:=filterList2, Operator:=xlFilterValues
Workbooks(sourceWB).Sheets(sourceWS).Range("A2:O" & lastrowSrc).SpecialCells _
(xlCellTypeVisible).Copy _
Destination:=Workbooks(destinationWB).Sheets(destinationWS).Cells(lastrowDest + 1, 1)
End Sub
One method is by using the Copy method of the Range object. This should generally be avoided though as this overwrites the clipboard. A safer option is to simply use rngDest.Value = rngSrc.Value. Note that for this to work the ranges must be the same size. Here is how this is normally used:
Dim dst As Range
Dim src As Range
Set src = Range("A1:B3") 'Data you want to copy
Set dst = Range("C1") 'First cell in the destination Range
Set dst = dst.Resize(src.Rows.Count, src.Columns.Count) 'Resize to match src
dst.Value = src.Value 'Copy to destination
This method has the benefit of preserving the clipboard!
I am able to copy the last row of one workbook and paste it after the last row of another workbook. I want to copy the entire data from row 2 (row 1 is header) in the first workbook and paste it after the last row of another workbook. Please advise me what changes are required in the code below to copy the entire data from row 2 instead of only the last row.
Dim lastS1Row As Long
Dim nextS2Row As Long
Dim lastCol As Long
Dim lCol As Long
Dim lCol1 As Long
Dim s1Sheet As Worksheet, s2Sheet As Worksheet
Dim source As String
Dim target As String
Dim path As String
Dim path1 As String
source = "Students" 'Source Worksheet Name
path1 = "H:\Shaikh_Gaus\scratch\VBA\Book17.xlsx"
path = "H:\Shaikh_Gaus\scratch\VBA\Book16.xlsx"
target = "Students" 'Target Worksheet Name
Application.EnableCancelKey = xlDisabled
Set s1Sheet = Workbooks.Open(path).Sheets(source)
Set s2Sheet = Workbooks.Open(path1).Sheets(target)
lastS1Row = s1Sheet.Range("A" & Rows.Count).End(xlUp).Row
nextS2Row = s2Sheet.Range("A" & Rows.Count).End(xlUp).Row + 1
lastCol = s1Sheet.Cells(1, Columns.Count).End(xlToLeft).Column
For lCol = 1 To lastCol
s2Sheet.Cells(nextS2Row, lCol) = s1Sheet.Cells(lastS1Row, lCol)
Next lCol
Next lCol1
s2Sheet.Activate
ActiveWorkbook.Close SaveChanges:=True
s1Sheet.Activate
ActiveWorkbook.Close
This adjusted version of your code should do the job:
Dim s1Sheet As Worksheet, s2Sheet As Worksheet
Dim source As String
Dim target As String
Dim path As String
Dim path1 As String
Dim rngSource As Range
Dim rngTargetStart As Range
source = "Students" 'Source Worksheet Name
path1 = "H:\Shaikh_Gaus\scratch\VBA\Book17.xlsx"
path = "H:\Shaikh_Gaus\scratch\VBA\Book16.xlsx"
target = "Students" 'Target Worksheet Name
Application.EnableCancelKey = xlDisabled
Set s1Sheet = Workbooks.Open(path).Sheets(source)
Set s2Sheet = Workbooks.Open(path1).Sheets(target)
Set rngSource = Range(s1Sheet.Range("A2"), s1Sheet.Cells.SpecialCells(xlCellTypeLastCell))
Set rngTargetStart = s2Sheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
rngTargetStart.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value
s2Sheet.Parent.Close SaveChanges:=True
s1Sheet.Parent.Close
I removed something what seemed unnecessary. The main thing is that now you don't loop through columns and rows. Now you can do it with one operation.
Avoid as much as you can things like .Select, .Activate. and .Copy if you just need values to be pasted. You can simply do something similar like I did:
Target.Value = Source.Value
After you set s1Sheet and s2Sheet I think you should be able to use these 2 lines to copy & paste the entire range at once:
'copy Cells A2 through last row and last column used
s1Sheet.Range(s1Sheet.Cells(2, 1), s1Sheet.Cells(s1Sheet.Cells(s1Sheet.Rows.Count, 1).End(xlUp).Row, _
s1Sheet.Cells(1, s1Sheet.Columns.Count).End(xlToLeft).Column)).Copy
'paste those cells in next blank row of second sheet
s2Sheet.Cells(s2Sheet.Cells(s2Sheet.Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteAll
'Here you go:
Range("A2").End(xlDown).select
selection.End(xlRight).select
selection.copy
'then active the next sheet for e.g Sheet2.Active
last_row = range("A1048576").end(xlup).row
range("A" & last_row).paste
' Done
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?