I'm very new to VBA. I have some code that will copy data that meets a certain criteria in one sheet to another master sheet. I have multiple other worksheets that I want to copy from into the master. How do I amend my code to do that please?
Thanks in advance.
Sub copyPaste()
Dim ws As Worksheet
Dim wt As Worksheet
Set ws = Sheets("S_Q")
Set wt = Sheets("master")
Dim i As Integer
Dim lr As Integer
lr = ws.Range("y" & Rows.Count).End(xlUp).Row
Dim lt As Long
For i = 1 To lr
lt = wt.Range("y" & Rows.Count).End(xlUp).Row
If ws.Range("bz" & i) > 14 Then
ws.Range("y" & i).EntireRow.Copy wt.Range("a" & lt + 1)
End If
Next i
End Sub
Without diving too far into the specifics of your code itself - will the criteria be the same for all worksheets you're wanting to run it on? And is the layout of the data in all of those worksheets?
If so, and if your current code is doing what you need it to do for Worksheet A and we just need to expand that to also handle Worksheets B through X, then you could get rid of your dim/set ws lines, and instead change your first line to
sub copyPaste(ws as worksheet)
This would allow you to then use a separate procedure to call this procedure for each of your worksheets that it needs to be run on. Below is an example using the worksheet from your original code:
call copyPaste(ThisWorkbook.Sheets("S_Q"))
I would put the sheets of interest to loop over in an array and loop that. I would also use Union to gather the qualifying ranges and paste in one go to be more efficient.
I would also use a helper function to retrieve the last row and add one to that to get next row.
Also, use Long rather than Integer to avoid potential overflow as there are more rows in a sheet than Integer can handle.
Option Explicit
Public Sub copyPaste()
Dim ws As Worksheet, wt As Worksheet, sheetsOfInterest(), unionRng As Range
Dim i As Long, lastRow As Long, lastRowMaster As Long
Application.ScreenUpdating = False
sheetsOfInterest = Array("Sheet1", "Sheet2", "S_Q")
Set wt = ThisWorkbook.Worksheets("master")
For Each ws In ThisWorkbook.Worksheets(sheetsOfInterest)
lastRow = GetLastRow(ws, 25)
For i = 1 To lastRow
If ws.Range("BZ" & i) > 14 Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, ws.Range("bz" & i))
Else
Set unionRng = ws.Range("BZ" & i)
End If
End If
Next i
If Not unionRng Is Nothing Then
With wt
unionRng.EntireRow.Copy .Range("A" & GetLastRow(wt, 1) + 1)
End With
End If
Set unionRng = Nothing
Next
Application.ScreenUpdating = True
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
After trying the filter on various columns and it working on some and not others; with no apparent reasoning. I decided to rejig the spreadsheets and put the column to be filtered in the first column. This seems to be working so far.
Related
I am attempting to have VBA scan cells in column DQ for a specific text value of "AcuteTransfer" and then to cut the row containing that cell and past into the first available row of a new sheet.
This value would be listed multiple times and each listing would need to be cut and pasted over
sheet containing the cell is "adds&reactivates" and sheet where row would be pasted to is "ChangeS".
Any recommendations would be amazing.
So far I have
Sub ohgodwhathaveIdone()
Dim endRow As Long
Dim Match1() As Variant
Dim ws As Worksheet
Set ws = Worksheets("adds&reactivates")
ICount = 0
endRow = Sheets("adds&reactivates").Range("DQ999999").End(xlUp).Row
Match1 = Sheet1.Range("DQ2:DQ" & endRow)
For I = LBound(Match1) To UBound(Match1)
If Match1(I, 1) = "AcuteTransfer" Then
Sheets("adds&reactivates").Cells(I, "A").EntireRow.Copy Destination:=Sheets("changes").Range("A" & Sheets("Changes").Rows.Count).End(xlUp).Offset(1)
Else
End If
Next I
End Sub
Try this out - this is assuming both pages have headers on row 1.
Option Explicit
Sub Test()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("adds&reactivates")
Set sht2 = ThisWorkbook.Worksheets("ChangeS")
For i = 2 To sht1.Cells(sht1.Rows.Count, "DQ").End(xlUp).Row
If sht1.Range("DQ" & i).Value = "AcuteTransfer" Then
sht1.Range("A" & i).EntireRow.Cut sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "DQ").End(xlUp).Row + 1)
End If
Next i
End Sub
I there I have the following problem: I would like to paste the results in a new sheet if the outcome is not "NO MATCH", how can I paste this in the new sheet and after the last used row? I get an error on the Active.Paste
Here is my code:
Public Sub CopyRows()
Sheets("Koppeling data").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 4).End(xlUp).Row
' Loop through each row
For x = 3 To 10
' Decide if to copy based on column D
ThisValue = Cells(x, 4).Value
If ThisValue = "NO MATCH" Then
Else
Rows(x).Copy
Sheets("All sessions").Select
Call FindingLastRow
ActiveSheet.Paste
Sheets("Koppeling data").Select
End If
Next x
End Sub
Sub FindingLastRow()
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("All sessions")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
End Sub
Give this a shot. I simplified the code a lot, removed the .Select statements - which should be avoided at all costs- , and assigned variables to objects and worked directly with them.
Public Sub CopyRows()
Dim wsK As Worksheet, wsA As Worksheet
Set wsK = Sheets("Koppeling data")
Set wsA = Sheets("All sessions")
Dim FinalRow as Long
FinalRow = wsk.Cells(wsk.Rows.Count, 4).End(xlUp).Row
' Loop through each row in Koppeling data
For x = 3 To FinalRow
' Decide if to copy based on column D
If wsK.Cells(x, 4).Value <> "NO MATCH" Then
wsK.Rows(x).EntireRow.Copy _
Destination:=wsA.Range("A" & wsA.Rows.Count).End(xlUp).Offset(1) 'used `.Offset(1)` here so it will paste one row below last row with data.
'use this to paste values
'wsk.Rows(x).Copy
'wsA.Range("A" & wsA.Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
Next x
End Sub
You have FindingLastRow as sub, which doesn't do anything. If you want to return the result (in your case the last row), you have to define it as a function:
Function FindingLastRow() as Long
'Your existing code
FindingLastRow = LastRow
End Function
This will return the value of last row, and in the main sub you can just paste into the following row:
Dim lastRow as Long
lastRow = FindingLastRow
ActiveSheet.Range("A" & lastRow + 1).Paste
Try to get away from using Worksheet.Select and Range .Select to accomplish your actions.
Public Sub CopyRows()
Dim x As Long, lastRow As Long, finalRow As Long
With Worksheets("Koppeling data")
' Find the last row of data
finalRow = .Cells(.Rows.Count, 4).End(xlUp).Row
' Loop through each row
For x = 3 To 10 'For x = 3 To finalRow
' Decide if to copy based on column D
If UCase(.Cells(x, 4).Value) <> "NO MATCH" Then
FindingLastRow Worksheets("All sessions"), lastRow
.Rows(x).Copy Destination:=Worksheets("All sessions").Range("A" & lastRow + 1)
End If
Next x
End With
End Sub
Sub FindingLastRow(ws As Worksheet, ByRef lr As Long)
With ws
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
End Sub
The ByRef allows you to pass a previously declared variable into your helper sub and have that variable return with a changed value.
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
I have two workbooks , one is a active list(database) and the other is a project tracker(dashboard).
Both workbooks have a project ID.
I want that the workbook and active list should have a loop to match the exact project IDs.
If the project ID is found in the active list, it would retrieve information from that row and overwrite the existing row in the project tracker,which contains that project ID.
This is an example of the code which i have done, I did something relevant but it does not seem to work :
Sub AAA()
'If Workbooks("Source.xlsm").Sheets("Sheet2").Range("A2").Value = Workbooks("Target.xlsm").Sheets("Sheet1").Range("A2").Value Then
'Workbooks("Source.xlsm").Sheets("Sheet2").Range("B2").Value = Workbooks("Target.xlsm").Sheets("Sheet1").Range("C2").Value
Dim a As Long
Dim lastrow As Long
Dim lastcol As Long
Dim source As Worksheet
Dim target As Worksheet
Set target = Workbooks("Target.xlsm").Sheets("Sheet1")
Set source = Workbooks("Source.xlsm").Sheets("Sheet2")
lastrow = source.Range("A" & target.Rows.Count).End(xlUp).Row
lastcol = target.Cells(2, target.Columns.Count).Column
target.Activate
For a = 2 To 50
If source.Range("A" & a).Value = target.Range("A" & a).Value Then
target.Range("C" & a).Select
Range(ActiveCell, ActiveCell.Offset(0)).Copy
source.Range("B" & a).PasteSpecial
End If
Next a
End Sub
You are misunderstanding how you use the Range object. This .Range("A").Value does not work, you need to include a row number as well, such as .Range("A1").Value.
Your logic assumes that both lists are in exactly the same order. Using the Range.Find method gets round that problem.
Sub AAA()
Dim source As Worksheet
Dim target As Worksheet
Dim cell As Range
Dim cellFound As Range
Set target = Workbooks("Target.xlsm").Sheets("Sheet1")
Set source = Workbooks("Source.xlsm").Sheets("Sheet2")
For Each cell In target.Range("A2:A50")
' Try to find this value in the source sheet
Set cellFound = source.Range("A:A").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not cellFound Is Nothing Then
' A matching value was found
' So copy the cell 2 columns across to the cell adjacent to matching value
' Do a "normal" copy & paste
cell.Offset(ColumnOffset:=2).Copy cellFound.Offset(ColumnOffset:=1)
' Or do a copy & paste special values
'cell.Offset(ColumnOffset:=2).Copy
'cellFound.Offset(ColumnOffset:=1).PasteSpecial xlPasteValues
Else
' The value in this cell does not exist in the source
' Should anything be done?
End If
Next
End Sub
Are you aware that you are using different sheets for source and for target?
target.Activate
For a = 2 To 50
If source.Range("A" & a).Value = target.Range("A" & a).Value Then
target.Range("C" & a).EntireRow.Select
Selection.Copy
source.Range("B" & a).PasteSpecial
End If
Next a
Not sure what volume of data you're going to be working with, but you could also use arrays to achieve what you're after.
Option Explicit
Sub AAA()
Dim i As Long, j As Long, k As Integer
Dim source As Worksheet, target As Worksheet
Dim arrTarget() As Variant, arrSource() As Variant
Dim lrowSrc As Long, lcolSrc As Long, lrowTrgt As Long, lcolTrgt As Long
Set target = Workbooks("Book4.xlsb").Sheets("Sheet1")
Set source = Workbooks("Book3.xlsb").Sheets("Sheet1")
lrowSrc = source.Cells(target.Rows.Count, 1).End(xlUp).Row
lcolSrc = source.Cells(2, source.Columns.Count).End(xlToLeft).Column
lrowTrgt = target.Cells(target.Rows.Count, 1).End(xlUp).Row
lcolTrgt = target.Cells(2, target.Columns.Count).End(xlToLeft).Column
target.Activate
arrTarget = target.Range(Cells(2, 1), Cells(lrowTrgt, lcolSrc))
source.Activate
arrSource = source.Range(Cells(2, 1), Cells(lrowSrc, lcolSrc))
target.Activate
For i = LBound(arrTarget, 1) To UBound(arrTarget, 1)
For j = LBound(arrSource, 1) To UBound(arrSource, 1)
If arrTarget(i, 1) = arrSource(j, 1) Then
For k = LBound(arrSource, 2) To UBound(arrSource, 2)
arrTarget(i, k) = arrSource(j, k)
Next k
Exit For
End If
Next j
Next i
target.Range("A2").Resize(UBound(arrTarget, 1), UBound(arrTarget, 2)).Value = arrTarget
End Sub
Working on 12,000 rows of data in the Target workbook and 25,000 in the Source workbook, with 6,000 matches, the code took 9.91 seconds to run.
I am trying to loop through all the worksheets in the activeworkbook to perform a repetitive task.
I currently have the code below:
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim rng1 As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
'This is marking several of the sheets of which I do not want to run the sub
If ws.Range("a9").Value = "x" Then
NextIteration:
End If
'Reference point is rng1 to select the desired range
With Range("a1:t100")
rng1 = .Find(what:="sector", LookIn:=xlValues).Row
End With
'return the row number for the sector header
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
'I am going to add the code below to finish out the task that I want to complete
Next
End Sub
I am sure the problem is that I'm misunderstanding something about how the for each loop actually works. Hopefully someone's answer will allow to better understand.
I really appreciate any help on this.
I made some edits to the code, and now I actually do have an error :) I tried making the changes you suggested for the "with ws.range etc..." piece of the code, and I get the object error 91.
Below is my new and "improved" code.
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim intAnchorRow As Integer
Dim intMktCapAnchor As Integer
Dim intSectorAnchor As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In ActiveWorkbook.Worksheets
'Filter out the sheets that we don't want to run
If ws.Range("a9").Value <> "x" Or ws.Name = "__FDSCACHE__" Or ws.Name = "INDEX" Then
'Get the anchor points for getting sort range and the sort keys
''''''THIS IS THE PART THAT IS NOW GIVING ME THE ERROR'''''''
With ws.Range("a1:t100")
intAnchorRow = .Find(what:="sector", LookIn:=xlValues).Row
intSectorAnchor = .Find(what:="sector", LookIn:=xlValues).Column
intMktCapAnchor = .Find(what:="Market Cap", LookIn:=xlValues).Column
End With
'Find the last row and column of the data range
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
Set SortRng = Range(Cells(intAnchorRow + 1, 1), Cells(LastRow, LastCol))
Range(SortRng).Sort key1:=Range(Cells(intAnchorRow + 1, intSectorAnchor), Cells(LastRow, intSectorAnchor)), _
order1:=xlAscending, key2:=Range(Cells(intAnchorRow + 1, intMktCapAnchor), Cells(LastRow, intMktCapAnchor)), _
order2:=xlDescending, Header:=xlNo
End If
Next
End Sub
Thanks again. This has been very helpful for me.
If I've understood your issue correctly, you don't want to use a worksheet with an x in cell A9.
If that's the case I would change the condition of the if statement to check if the cell does not contain the x. If this is true, it enters the rest of the code. If not, it goes to the next iteration.
Also, your NextIteration: doesn't do anything in the If statement.
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim rng1 As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
'This is marking several of the sheets of which I do not want to run the sub
If ws.Range("a9").Value <> "x" Then
'Reference point is rng1 to select the desired range
With Range("a1:t100")
rng1 = .Find(what:="sector", LookIn:=xlValues).Row
End With
'return the row number for the sector header
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
'I am going to add the code below to finish out the task that I want to complete
End If
Next
End Sub
The : operator is used to return the code to that line after a goto call.
For example
sub gotoEx()
for i = 1 to 10
if i = 5 then
goto jumpToHere
end if
next i
jumpToHere: '<~~ the code will come here when i = 5
'do some more code
end sub
And of course you can use this structure in your code if you wish, and have the jumpToHere: line just before the next
e.g.
for each ws in wb.Worksheets
if ws.Range("a9").Value = "x" then
goto jumpToHere
end if
'the rest of your code goes here
jumpToHere:
next
I am importing some date to worksheet which needs to be ranged for validation and reference in other worksheets.
Say I have 4 columns in worksheet(WS1) but the row count is dynamic on every import. How can i range the columns(A:D)?
Please help.
Regards,
Mani
Use a lastRow variable to determine the last row. I included a few examples of this. Also on this example is a lastCol variable.. You can use this if the number of Columns is dynamic as well.
Private Sub lastRow()
Dim lastRow As Long
Dim lastCol As Long
Dim sheet As String
sheet = "WS1"
lastRow = Sheets(sheet).Range("A" & Rows.Count).End(xlUp).row 'Using Range()
lastRow = Sheets(sheet).Cells(Rows.Count, "A").End(xlUp).row 'Using Cells()
lastCol = Sheets(sheet).Cells(2, Columns.Count).End(xlToLeft).Column
End Sub
You can loop through your sheet easily enough using variables also. Using Cells(row,col) instead of Range(A1). you can use numbers or a letter in quotes for the column as shown in the example.
This example looks at WS1 and matches someValue. If the value in Column A of WS1 = somevalue, the record is copied to a "Master" Sheet.
Sub LoopExample()
Dim mRow As Long 'used for a master row
For lRow = 2 To lastRow
If Sheets(sheet).Cells(lRow, 1) = someValue Then
'perform something here like this. Copy columns A:D to the Master Sheet if match
For lCol = 1 To 4 'or you could go 1 to lastCol if you needed it dynamic
Sheets("MASTER").Cells(mRow, lCol) = Sheets(sheet).Cells(lRow, lCol) 'mRow as Row on Master
Next lCol
mRow = mRow + 1 'Increment the Master Row
End If
Next lRow
End Sub
Thanks anyways. But what i wanted was just to Name ranges the columns in worksheet.
I have already accomplished the copy and paste (Loading data b/w worksheets).
This is what i wanted.
vRowCount = DestWorkSheet.Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row
vColCount = DestWorkSheet.Cells(1, 1).SpecialCells(xlCellTypeLastCell).Column
DestWorkSheet.usedRange.Columns.AutoFit
AddNamedRange Dest_RATES, DATA_Dest_RATES
Where AddNamedRange is a function,
Public Sub AddNamedRange(ByVal sheetCodeName As String, ByVal namedRange As String)
Dim rngToBeNamed As Range
Dim ws As Worksheet
On Error GoTo AddNamedRange_Error
Set rngToBeNamed = GetUsedRange(sheetCodeName)
Set ws = rngToBeNamed.Worksheet
ws.Names.Add name:=namedRange, RefersTo:=ws.Range(rngToBeNamed.Address)
On Error GoTo 0
Exit Sub
AddNamedRange_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AddNamedRange of Module UtilitiesRange"
End Sub
Regards,
Mani
Seems like you could just use something like this in the sheet module:
Private Sub Worksheet_Change(ByVal target As Range)
Dim i As Long
Dim NamesOfNames(1 To 4) As String
NamesOfNames(1) = "NameOfColumn1"
NamesOfNames(2) = "NameOfColumn2"
NamesOfNames(3) = "NameOfColumn3"
NamesOfNames(4) = "NameOfColumn4"
For i = 1 To 4
ThisWorkbook.Names.Add Name:=NamesOfNames(i), _
RefersTo:=Range(Cells(1, i), Cells(Cells(Rows.Count, i).End(xlUp).Row, i))
Next i
End Sub