I am trying to make the rang is dynamic in the macro without specifying the last line x.Sheets("SheetName").Range("A2:K1000").Copyin 1000 line I want to change it to dynamic because sometimes I have less or more than that.
Try this:
Sub Test()
Dim lRow as Long
Dim sht as Worksheet
Set sht = x.Sheets("SheetName")
lRow = sht.Cells(sht.Rows.Count, 2).End(xlUp).Row
sht.Range("A2:K" & lRow).Copy
End Sub
Something like this will do the job:
Option Explicit
Public Sub TestMe()
Dim lngLastRow As Long
lngLastRow = 150
'or come up with a function from here
'https://www.rondebruin.nl/win/s9/win005.htm
With x.Worksheets("SheetName")
.Range(.Cells(2, 1), .Cells(lngLastRow, 1)).Copy
End With
End Sub
In general, last row in a given column or last column in a given row is something, that you will do quite a lot of time in VBA. Thus, it is a good idea to read this:
https://www.rondebruin.nl/win/s9/win005.htm
Typically, look for the last row containing a value from the bottom up.
with x.Sheets("SheetName")
.Range(.cells(2, "A"), .cells(.rows.count, "K").end(xlup)).Copy
'paste it somewhere
end with
Related
I am trying to do a copy in VBA, as part of a bigger macro so it needs to be in VBA, of an unknown range in a specific worksheet.
I have this code that work if I am in that worksheet:
Sub Copy()
Range("O2", Range("O" & Cells(Rows.Count, "A").End(xlUp).Row)).copy
End Sub()
And I have below that works for a specific range:
Sub Test()
Worksheets("Data").Range("O2:O10").Copy
End Sub()
How can I make the second code work as unspecific.
Thanks,
You should practice to always fully qualify all your Sheet and Range objects.
The code below is a little long, but it's good practice to define and set all your objects and variables.
Code
Option Explicit
Sub Test()
Dim Sht As Worksheet
Dim LastRow As Long
' set your worksheet object
Set Sht = ThisWorkbook.Worksheets("Data")
With Sht
' get last row in column A
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' copy dynamic range in column O
.Range("O2:O" & LastRow).Copy
End With
End Sub
The simplest & dirtiest solution is this one:
Range("O2:O" & Cells(Rows.Count, "A").End(xlUp).Row).Copy
or you can isolate the last row as a separate variable:
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("O2:O" & lastRow).Copy
at the end, one may decide to declare the range to be copied as a separate variable and to work with it, declaring the parent worksheet as well:
Public Sub TestMe()
Dim lastRow As Long
Dim ws As Worksheet
Dim rangeToCopy As Range
Set ws = workshetes("Sheet1")
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rangeToCopy = .Range("O2:O" & lastRow)
rangeToCopy.Copy
End With
End Sub
And going really one step further is using a dedicated function for finding the last row per worksheet (GitHub repo here):
Function lastRow(wsName As String, Optional columnToCheck As Long = 1) As Long
Dim ws As Worksheet
Set ws = Worksheets(wsName)
lastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row
End Function
At some point, your code will have to know the range that's going to be copied, right? You assign that to a variable and you use it.
Option Explicit
Sub Test()
Dim startRow as Long
startRow = 'your method of determining the starting row
Dim startCol as Long
startCol = 'your method of determining the starting column
Dim endRow as Long
endRow = 'your method of determining the ending row (Last used row would work just fine)
Dim endCol as Long
endCol = 'your method of determining the ending column
With Worksheets("Data")
.Range(.Cells(startRow, startCol), .Cells(endRow, endCol)).Copy
End with
End Sub
you could use a Function you pass the "seed" range to and returning a range from passed one to the last not empty cell in the same column, as follows (explanations in comments)
Function GetRange(rng As Range) As Range
With rng.Parent ' reference passed range parent worksheet
Set GetRange = .Range(rng, .Cells(.Rows.Count, rng.Column).End(xlUp)) ' return referenced sheet range from passed range to passed range column last not empty cell
End With
End Function
to be used as follows:
Sub Test()
GetRange(Worksheets("Data").Range("O2")).Copy
End Sub
you could enhance the function and have it handle a given "final" row
Function GetRange(rng As Range, Optional finalRow As Variant) As Range
With rng.Parent ' reference passed range parent worksheet
If IsMissing(finalRow) Then ' if no "final" row passed
Set GetRange = .Range(rng, .Cells(.Rows.Count, rng.Column).End(xlUp)) ' return referenced sheet range from passed range to passed range column last not empty cell
Else 'else
Set GetRange = .Range(rng, .Cells(finalRow, rng.Column)) ' return referenced sheet range from passed range to passed range column cell in give "final" row
End If
End With
to be used as follows:
Sub Test()
GetRange(Worksheets("Data").Range("O2"), 2).Copy
End Sub
having kept "final" row as optional, the function can be used with or without passing it:
Sub Test()
GetRange(Worksheets("Data").Range("O2")).Copy ' this will copy worksheet "Data" range from row 2 down to its column "O" last not empty row
GetRange(Worksheets("Data").Range("O2"), 3).Copy ' this will copy worksheet "Data" range from row 2 down to row 3
End Sub
You clearly don't enjoy using variables, so:
Worksheets("Data").Range("O2", Worksheets("Data").Range("O" & Cells(Rows.Count, "A").End(xlUp).Row)).copy
would suffice.
Generally, a more common solution would be to use intersect and CurrentRegion:
Application.intersect(Worksheets("Data").Range("O2").CurrentRegion,Worksheets("Data").Range("O2:O999999")).copy
It might be a simple question but after hours of trying about to give up...
I want the macro to find the range from a minimum to a maximum. This range should be copied and pasted to some kind of a "summary sheet".
I was able to make the macro find the min and the max and I also got a copy-paste instruction that works.
Could somebody please help me to combine these instructions into one?
Here is my macro as far as I came:
Sub Enter_Formula()
Dim blatt
Dim sheetName As String
For i = 1 To Sheets.Count
Sheets(i).Select
Range("=Min(A59:A86):=Max(A:A)").Copy Range("C1")
Next
End Sub
Thank you!!
I'd go as follows:
Sub Enter_Formula()
Dim sht As Worksheet, summarySht As Worksheet
Set summarySht = Worksheets("Summary") '<--| change "Summary" to your actual "Summary" sheet name
For Each sht In Worksheets
If sht.Name <> summarySht.Name Then
With sht.Range("A59:A86")
.Parent.Range(.Find(what:=WorksheetFunction.Min(.Cells), lookat:=xlWhole, LookIn:=xlValues), .EntireColumn.Find(what:=WorksheetFunction.Max(.EntireColumn), lookat:=xlWhole, LookIn:=xlValues)).Copy summarySht.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
End With
End If
Next
End Sub
Might be a bit faster to evaluate the expression directly (tested):
Dim ws As Worksheet
For Each ws In Worksheets
ws.Range("Index(A59:A86,Match(Min(A59:A86),A59:A86,0)):Index(A:A,Match(Max(A:A),A:A,0))").Copy ws.Range("C1")
Next
I have an excel with multiple sheets and would like to copy or better say want to extend the last column every month.
Eg:-
I have a sheet with sheet named sheet1,sheet2,sheet3,sheet4,sheet5...every sheet at the end of the month has formulas.Once a month is over I would like to add a new column with new month and copying the existing formula to the new column.Let say I have last month Jan and I need VBA to add new column with month as Feb and copy all the formula to the new column.
Sometimes I also need to copy multiple column (eg:-Column C-J) and replicate the next 8 column with new month and formula.
Tried with recording macro but the issue is it doesn't create a new column for every month it just copy paste it in same column rather than creating a new one for every month
It is difficult to understand the problem without seeing the formulas.
It sounds like you could start by using the AutoFill. You could do this manually by selecting the range you want to copy and dragging the cross in the bottom right corner. This will update the month automatically.
You can achieve this with VBA, such as:
Public Sub copyRange()
Dim rngSource As Range
Dim rngDestination As Range
rngSource = ActiveSheet.Range("A1:A20")
rngDestination = ActiveSheet.Range("B1:B20")
rngSource.AutoFill Destination:=rngDestination
End Sub
Either way, I can't tell how to reset the formulae for the new months without seeing the cell code.
UPDATE: To AutoFill multiple columns on multiple tabs
Public Sub copySpecifiedColumns()
copyRanges InputBox("How many columns do you wish to copy?", "Copy Columns", "1")
End Sub
Private Sub copyRanges(copyCols As Byte)
Dim ws As Worksheet, lastCol As Integer, lastRow As Integer
Dim rngSource As Range, rngDestination As Range
Dim sheetList As Variant
sheetList = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")
For Each ws In ThisWorkbook.Sheets
If (UBound(Filter(sheetList, ws.Name)) > -1) Then
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set rngSource = ws.Range(ws.Cells(1, lastCol - copyCols + 1), _
ws.Cells(lastRow, lastCol))
Set rngDestination = ws.Range(ws.Cells(1, lastCol - copyCols + 1), _
ws.Cells(lastRow, lastCol + copyCols))
rngSource.AutoFill rngDestination
End If
Next ws
End Sub
I Agree it's a bit difficult to understand what you are trying to achieve here. From what I understand if you want to make a copy of last column in the next column in each sheet and change the 1st cell of that column to the month at the time. This code can help.
Sub copy_col()
Dim lColumn As Long
For Each Sheet In Worksheets
lColumn = Sheet.Cells(1, Columns.Count).End(xlToLeft).Column
Sheet.Columns(lColumn).Copy Sheet.Columns(lColumn + 1)
Sheet.Cells(1, lColumn + 1).Value = Month(Now())
Next Sheet
End Sub
If this is not what you want then please explain your problem more briefly.
Thanks
Extend List and Update Formula
Usage
ExtendList 5, "Sheet1", "Sheet3"
Where
1. 5, is the Column to Duplicate to the next empty Column
2. "Sheet1" is the sheet referenced in the original formula
3. "Sheet3" is the replace sheet name
Original Formula
=Sheet1!$A10
New Formula
=Sheet3!$A10
Sub ExtendList(SourceColumn As Long, OriginalSheetName As String, NewSheetName As String)
On Error Resume Next
Dim newColumnNumber As Integer
Worksheets(NewSheetName).Name = NewSheetName
If Err.Number <> 0 Then
Err.Clear
Exit Sub
End If
On Error GoTo 0
newColumnNumber = Range(Cells(1, Columns.Count), Cells(Rows.Count, Columns.Count)).End(xlToLeft).Offset(, 1).Column
Columns(SourceColumn).Copy Columns(newColumnNumber)
Columns(newColumnNumber).Replace What:=OriginalSheetName, Replacement:=NewSheetName, lookat:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
End Sub
This will only work if the column reference is absolute:
Correct
$A1 or $A$2
Incorrect
A1 or A$1
I am trying to run a code that I found also here. the code is removing duplicates on each column on each spreed sheet on a workbook treating it as a separate entity. whenever I try to run the code the compiler error says "sub or function not defined" and there is a yellow highlight on the most upper part and the "LastCell" got a blue highlight. I already add the solver reference but still it gives me the same error. I just can't figure out what the problem is if it's on the code or should I add another reference.
Sub Removeduplicates()
Dim ws As Workbook
Dim lLastcol As Long
Dim lLastrow As Long
Dim i As Long
For Each ws In ThisWorkbook.Worksheets
lLastcol = LastCell(ws).Column
For i = 1 To lLastcol
lLastrow = LastCell(ws, i).Row
With ws
.Range(.Cells(1, i), .Cells(lLastrow, i)).Removeduplicates Columns:=1, Header:=xlNo
End With
Next i
Next ws
End Sub
Looks like lasy cell is the function you thought you had. We is the worksheet passed in. Thee function will use something like
Function lastcell(w as worksheet) as range
Set Lastcell=w.range("a" & w.rows.count).end(xlup)
End function
After deciphering your code snippet, this is the best that I can come up with.
Function lastCell(ws As Worksheet, _
Optional c As Variant, _
Optional r As Variant) As Range
With ws
If IsMissing(c) And IsMissing(r) Then
Set lastCell = .Cells.SpecialCells(xlCellTypeLastCell)
ElseIf IsMissing(c) And Not IsMissing(r) Then
Set lastCell = .Cells(r, .Columns.Count).End(xlToLeft)
ElseIf IsMissing(r) And Not IsMissing(c) Then
Set lastCell = .Cells(.Rows.Count, c).End(xlUp)
Else
Set lastCell = .Cells(r, c)
End If
End With
End Function
Copy that code to a module code sheet in your VBA project. It can tested with a short sub procedure like the following.
Sub test()
Dim ws1 As Worksheet
Set ws1 = ActiveSheet
Debug.Print lastCell(ws1).Address(0, 0) '<~~ last cell on worksheet
Debug.Print lastCell(ws1, 3).Address(0, 0) '<~~ last used cell in column C
Debug.Print lastCell(ws1, , 4).Address(0, 0) '<~~ last used column on row 4
End Sub
If you're referring to the solution of Darren Bartrup-Cook here, make sure to copy the function LastCell to your code as well.
i'm trying to make a macro which:
goes through a table
looks if value in column B of that table has a certain value
if it has, copy that row to a range in an other worksheet
The result is similar to filtering the table but I want to avoid hiding any rows
I'm kinda new to vba and don't really know where to start with this, any help much appreciated.
That is exactly what you do with an advanced filter. If it's a one shot, you don't even need a macro, it is available in the Data menu.
Sheets("Sheet1").Range("A1:D17").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("G1:G2"), CopyToRange:=Range("A1:D1") _
, Unique:=False
Try it like this:
Sub testIt()
Dim r As Long, endRow as Long, pasteRowIndex As Long
endRow = 10 ' of course it's best to retrieve the last used row number via a function
pasteRowIndex = 1
For r = 1 To endRow 'Loop through sheet1 and search for your criteria
If Cells(r, Columns("B").Column).Value = "YourCriteria" Then 'Found
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("Sheet2").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
'Switch back to your table & continue to search for your criteria
Sheets("Sheet1").Select
End If
Next r
End Sub
Selects are slow and unnescsaary. The following code will be far faster:
Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
For i = 2 To ws1.Range("B65536").End(xlUp).Row
If ws1.Cells(i, 2) = "Your Critera" Then ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
Next i
End Sub
you are describing a Problem, which I would try to solve with the VLOOKUP function rather than using VBA.
You should always consider a non-vba solution first.
Here are some application examples of VLOOKUP (or SVERWEIS in German, as i know it):
http://www.youtube.com/watch?v=RCLUM0UMLXo
http://office.microsoft.com/en-us/excel-help/vlookup-HP005209335.aspx
If you have to make it as a macro, you could use VLOOKUP as an application function - a quick solution with slow performance - or you will have to make a simillar function yourself.
If it has to be the latter, then there is need for more details on your specification, regarding performance questions.
You could copy any range to an array, loop through this array and check for your value, then copy this value to any other range. This is how i would solve this as a vba-function.
This would look something like that:
Public Sub CopyFilter()
Dim wks As Worksheet
Dim avarTemp() As Variant
'go through each worksheet
For Each wks In ThisWorkbook.Worksheets
avarTemp = wks.UsedRange
For i = LBound(avarTemp, 1) To UBound(avarTemp, 1)
'check in the first column in each row
If avarTemp(i, LBound(avarTemp, 2)) = "XYZ" Then
'copy cell
targetWks.Cells(1, 1) = avarTemp(i, LBound(avarTemp, 2))
End If
Next i
Next wks
End Sub
Ok, now i have something nice which could come in handy for myself:
Public Function FILTER(ByRef rng As Range, ByRef lngIndex As Long) As Variant
Dim avarTemp() As Variant
Dim avarResult() As Variant
Dim i As Long
avarTemp = rng
ReDim avarResult(0)
For i = LBound(avarTemp, 1) To UBound(avarTemp, 1)
If avarTemp(i, 1) = "active" Then
avarResult(UBound(avarResult)) = avarTemp(i, lngIndex)
'expand our result array
ReDim Preserve avarResult(UBound(avarResult) + 1)
End If
Next i
FILTER = avarResult
End Function
You can use it in your Worksheet like this =FILTER(Tabelle1!A:C;2) or with =INDEX(FILTER(Tabelle1!A:C;2);3) to specify the result row. I am sure someone could extend this to include the index functionality into FILTER or knows how to return a range like object - maybe I could too, but not today ;)