I'm trying to create a macro that uses Index/match functions to match and pull data from one sheet into another. I did it in Excel and it works perfect. However the reports are "dynamic" (the size changes) so I need the last row of my code to be dynamic as well.
The following is what I have done. I'm NOW getting a "type mismatch" error (I emphasize "now" since every time I find a solution for one error another pop's up).
Dim prosheet As Worksheet
Dim prosheet2 As Worksheet
Set prosheet2 = ThisWorkbook.Sheets("shipstation")
Set prosheet = ThisWorkbook.Sheets("macrotestfb")
lr1 = prosheet.Cells(Rows.Count, 1).End(xlUp).Row
lr2 = prosheet2.Cells(Rows.Count, 1).End(xlUp).Row
lrship = prosheet.Cells(Rows.Count, 10).End(xlUp).Row
lrindex = prosheet2.Cells(Rows.Column, 14).End(xlUp).Row
'CALCULATE SHIPPING COST
For x = prosheet.range("j6") To lrship
x = Application.WorksheetFunction.Index(prosheet2.range("a1:n" & lrindex), Application.WorksheetFunction.Match(prosheet.range("a6:a" & lr1), prosheet2.range("a1:a" & lr2), 0), prosheet2.range("f2"))
Next x
Match, in its non array form, only likes one value in the first criterion and not a range.
Also WorksheetFunction.Match will throw an error that will stop the code if a match is not found.
I like to pull the match into its own line and test for the error.
I also adjusted your For statement.
There is no detriment to searching an entire column so I got rid of a few of you last row searches as they are not needed.
Dim prosheet As Worksheet
Dim prosheet2 As Worksheet
Dim x As Long
Dim t As Long
Set prosheet2 = ThisWorkbook.Sheets("shipstation")
Set prosheet = ThisWorkbook.Sheets("macrotestfb")
lrship = prosheet.Cells(Rows.Count, 1).End(xlUp).Row
'CALCULATE SHIPPING COST
For x = 6 To lrship
t = 0
On Error Resume Next
t = Application.WorksheetFunction.Match(prosheet.Range("A" & x), prosheet2.Range("A:A"), 0)
On Error GoTo 0
If t > 0 Then
prosheet.Cells(x, "J").Value = prosheet2.Range("F"&t)
Else
prosheet.Cells(x, "J").Value = "Item does not Exist"
End If
Next x
Note:
Instead of an Index/Match combo which you might use on the worksheet, you can use Application.Match in VBA. Something like this:
Sub GetMatch
Dim indexRng As Range, matchRng as Range
Set indexRng = ThisWorkbook.Worksheets("Sheet1").Range("A1:A10")
Set matchRng = ThisWorkbook.Worksheets("Sheet1").Range("B1:B10")
debug.print indexRng.Cells(Application.Match("something",matchRng,0)).Value
End Sub
Related
First of all I would like to introduce myself. Iam Miguel and I recently started to learn VBA in order to improve and save time at work. I am familiar with formulas, all types, but when turning to VBA I get sometimes stuck.
I am trying to loop the range A2:A355 from Sheet"Aux" and copy each value to sheet "CS", and each value shall be pasted in Column A:A, but with the offset given in range B2:B355 Sheet "Aux". For Example I give the example attached.
Sample Code:
This is the code:
Sub cablexsection()
Dim s As Integer
Dim smax As Integer
smax = Sheets("Aux").Range("b1").Value
Sheets("CS").Activate
For s = 3 To smax
Sheets("CS").Cells(s, 1).Value = Sheets("Aux").Cells(s, 1).Value
'here I have to set the offset to down in order to paste cells given Sheets("Aux").Cells(s, 2) values
Next s
End Sub
And under the link you can find the file to be worked in:
Original File
Thank you very much and sorry if this question is repeated. I have tried to look through the forum but maybe I do not know what to write exactly.
Try this
Option Explicit
Sub CableXsection()
Dim wsAux As Worksheet, wsCS As Worksheet
Dim s As Long, sMax As Long, offSetCell As Range
Set wsAux = ThisWorkbook.Worksheets("Aux")
Set wsCS = ThisWorkbook.Worksheets("CS")
sMax = wsAux.Range("B1").Value
Application.ScreenUpdating = False
For s = 3 To sMax
Set offSetCell = wsAux.Cells(s, 2) '2 is the offset column from the same row
If Not IsError(offSetCell) And IsNumeric(offSetCell) Then
wsCS.Cells(offSetCell.Value2 + s, 1).Value = wsAux.Cells(s, 1).Value
End If
Next
Application.ScreenUpdating = True
End Sub
I'll make this one as direct as possible.
Three work sheets in play. Notes, shGather and Delay Report. As the Notes worksheet is updated, it finds flights that are delayed and automatically loads them to the shGather sheet. This functionality is working just fine. My question is in regards to the update event of the shGather worksheet.
I have the following code on the shGather worksheet. The intent is to run the array any time the sheet updates. The information on the shGather, if appropriate, then populates the Delay report.
Sub wsGather_Change(ByVal Target As Range)
Dim wsg As Worksheet
Dim wsd As Worksheet
Dim a As Long 'Total Array
'Dim b As Long
Dim i As Long 'Rows
Dim j As Long 'Columns
Dim lr As Long 'lr is shorthand for last row in the count
Dim cr As Long 'cr is shorthand for current row
Dim cc As Long 'cc is shorthand for current column
Dim arval As String 'array values
Dim aval As Variant 'A column on the shGather worksheet. This value will determine if the information is added to the array
Dim array1()
If Not Intersect(Target, wsg.Range("A2:A15")) Is Nothing Then
Set wsg = Worksheets("Gather") 'Add data from this worksheet to the array
Set wsd = Worksheets("Delay Report") 'deposit information from the array to this worksheet
lr = wsg.Cells(Rows.Count, "A").End(xlUp).Row
arval = "" 'This will be the total strig value of the individual array values that are captured
a = 0 'counts the total number of rows of data that exist in the array
For i = 2 To lr 'Start the array
aval = wsg.Range("A" & i).Value
If aval = "Y" Then 'Set the search parameters
arval = wsg.Range("B" & i).Value & "~#pop#~" 'Start collecting data with the B column
For j = 7 To 14
arval = arval & wsg.Cells(i, j).Value & "~#pop#~" 'continue collecting information in the various columns
Next j
ReDim Preserve array1(a)
array1(a) = arval
a = a + 1
End If
Next i
wsd.Range("G2:O15").ClearContents 'Clears the inserts range
If a > 0 Then
cr = 2
For i = LBound(array1) To UBound(array1)
cc = 6
newarr = Split(array1(i), "`#pop#~")
For j = LBound(newarr) To UBound(newarr)
wsd.Cells(cr, cc).Value = newarr(j)
cc = cc + 1
Next j
cr = cr + 1
Next i
End If
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I can't seem to figure out why I'm not getting array output results to the Delay Report. I'm not even sure that the code is firing on the correct event which is what I suspect. The shGather sheet has no direct inputs from any user. It just collects data.
I suspect either I have the wrong event, or there is something else wrong with my code. Any insights would be helpful.
I have taken a great deal of time trying to understand this, I'm closer but still learning. At least this time I have code to display.
See Tim's comment re why it isn't firing. That said, I don't believe your code is going to do what you want anyway. For instance, your line If Not Intersect(Target, wsg.Range("A2:A15")) Is Nothing Then will always equal nothing, because wsg hasn't been set to anything when it is called.
Also, I take it you have some kind of worksheet_change event on the Notes sheet that populates the Gather sheet, and then this event is supposed to kick in and do something else? If so, just move the "doing stuff" bit of this code to that other event handler...doesn't make sense to have two event handlers on different sheets responding to one thing the user does.
I´m trying to do a VLOOKUP of a column data set at a Sheet called "SyS" in G column. and I'd like to Vlookup relevant data using columns in another sheet called "CONF_mapping", located in the same Workbook. I need to find my data located at the range ("A1:E65000") (It's at column A, but I need to retrieve data from other columns with my vlookup to SyS). I'm not getting good results with my code, and I beg your pardon, it´s my first question in the forum.
Worksheets("SyS").Select
Dim wsThis As Worksheet
Dim aCell As Range
Sheets("CONF_mapping").Columns(2).Copy Destination:=Sheets("SyS").Columns(8)
Set wsThis = Sheets("SyS")
With wsThis
For Each aCell In .Range("A1:E65000")
'.Cells(aCell.Row, 8) = "Not Found"
On Error Resume Next
.Cells(aCell.Row, 8) = Application.WorksheetFunction.VLookup( _
aCell.value, wsThat.Range("G2:G65000"), 2, False)
On Error GoTo 0
Next aCell
End With
Worksheets("SyS").Select
I have find this code but I was not able to make it works for me.
I would appreciate any help.
You have mistake here:
VLookup(aCell.value, wsThat.Range("G2:G65000"), 2, False)
Range "G2:G65000" Have just 1 column G, but you try to get column#2 which does not exists.
UPD:
I guess you need something like this:
Const COLUMN_TO_MATCH_IN_SYS = 8
Const COLUMN_TO_MATCH_IN_CONF = 1
Sub test()
Dim wsSys As Worksheet
Dim wsConf As Worksheet
Set wsSys = Sheets("SyS")
Set wsConf = Sheets("CONF_mapping")
Dim RowSys As Range
Dim RowConf As Range
For Each RowSys In wsSys.UsedRange.Rows
For Each RowConf In wsConf.UsedRange.Rows
If RowSys.Cells(1, COLUMN_TO_MATCH_IN_SYS) = _
RowConf.Cells(1, COLUMN_TO_MATCH_IN_CONF) Then
' Copy row values which is needed
RowSys.Cells(1, 6) = RowConf.Cells(1, 1) ' From column A(conf) to G(sys)
RowSys.Cells(1, 7) = RowConf.Cells(1, 2) ' From column B(conf) to H (sys)
End If
Next aCell
Next
End Sub
With this solution you don't need to search the Range for each cell (just for each row), so it will work 5 times faster.
I'm very new to VBA (~4 days new) and have tried to solve this issue in my usual method, through reading lots of different posts on resources like this and experimenting, but have not been able to quite get the hang of it. I hope you fine folks are willing to point out where I'm going wrong with this. I've looked at a lot (all?) of the threads with similar issues but haven't been able to cobble together a solution for myself from them. I hope you'll forgive this if it has already been answered somewhere else.
Context:
I've got a spreadsheet with items in rows 5-713 down column B (merged up to cell J) where for each date (Columns K-SP) the item is scored either a 1 or a 0. My goal is to create a list at the bottom of the worksheet that contains all items which have gone from 1 to 0. To start, I've simply been trying to get my "generate list" button to copy all rows with a 0 in them to the bottom, figuring I would tweak it later to do exactly what I wanted. I've tried several things and gotten several different errors.
Worksheet Sample for a visual of what I'm talking about.
I've gone through several different attempts and have had limited success with each, usually getting a different error every time. I've had "method 'range of object' _Worksheet failed", "object required", "type mismatch", "out of memory", and a few others. I'm sure I'm simply not grasping some of the basic syntax, which is causing some problems.
Here is the latest batch of code, giving me the error 'type mismatch'. I've also tried having 'todo' be string but that just shoots out 'object required'
Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim y As Integer, z As Integer, todo As Range
Set todo = ThisWorkbook.ActiveSheet.Range(Cells(5, 2), Cells(713, 510))
y = 5
z = 714
With todo
Do
If todo.Rows(y).Value = 0 Then
todo.Copy Range(Cells(z, 2))
y = y + 1
z = z + 1
End If
Loop Until y = 708
End With
Application.ScreenUpdating = True
End Sub
Another attempt I thought was promising was the following, but it gives me 'out of memory'.
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim y As Integer, z As Integer
y = 5
z = 714
Do
If Range("By:SPy").Value = 0 Then
Range("By:SPy").Copy Range("Bz")
y = y + 1
z = z + 1
End If
Loop Until y = 708
Application.ScreenUpdating = True
End Sub
Just to reiterate, the code attempts I've posted were simply to get any row containing 0's to the bottom of the spreadsheet, however, if there's a way define the criteria to search for 1's that turn to 0's, that would be amazing! Also, I'm not sure how to differentiate a 0 in the actual data and a zero in the item name (for example, it would not be great to have 'Item 10' go into the list just because 10 is a 1 with a 0 after it).
Any help to figure out this first step, or even how to have it scan for 1's that turn to 0's would be wonderfully appreciated. I'm sure I'm missing something simple and hope you guys can forgive my ignorance.
Thanks!
This looks through the data and copies it down below the last row of the data. It is assuming there is nothing below the data. It also only looks for zeros after it finds a 1.
Sub findValueChange()
Dim lastRow As Long, copyRow As Long, lastCol As Long
Dim myCell As Range, myRange As Range, dataCell As Range, data As Range
Dim hasOne As Boolean, switchToZero As Boolean
Dim dataSht As Worksheet
Set dataSht = Sheets("Sheet1") '<---- change for whatever your sheet name is
'Get the last row and column of the sheet
lastRow = dataSht.Cells(Rows.Count, 2).End(xlUp).row
lastCol = dataSht.Cells(5, Columns.Count).End(xlToLeft).Column
'Where we are copying the rows to (2 after last row initially)
copyRow = lastRow + 2
'Set the range of the items to loop through
With dataSht
Set myRange = .Range(.Cells(5, 2), .Cells(lastRow, 2))
End With
'start looping through the items
For Each myCell In myRange
hasOne = False 'This and the one following are just flags for logic
switchToZero = False
With dataSht
'Get the range of the data (1's and/or 0's in the row we are looking at
Set data = .Range(.Cells(myCell.row, 11), .Cells(myCell.row, lastCol))
End With
'loop through (from left to right) the binary data
For Each dataCell In data
'See if we have encountered a one yet
If Not hasOne Then 'if not:
If dataCell.Value = "1" Then
hasOne = True 'Yay! we found a 1!
End If
Else 'We already have a one, see if the new cell is 0
If dataCell.Value = "0" Then 'if 0:
switchToZero = True 'Now we have a zero
Exit For 'No need to continue looking, we know we already changed
End If
End If
Next dataCell 'move over to the next peice of data
If switchToZero Then 'If we did find a switch to zero:
'Copy and paste whole row down
myCell.EntireRow.Copy
dataSht.Cells(copyRow, 2).EntireRow.PasteSpecial xlPasteAll
Application.CutCopyMode = False
copyRow = copyRow + 1 'increment copy row to not overwrite
End If
Next myCell
'housekeeping
Set dataSht = Nothing
Set myRange = Nothing
Set myCell = Nothing
Set data = Nothing
Set dataCell = Nothing
End Sub
I am trying to copy the entire range from "Leads" sheet after the last row of "TempDataNew"
If Sheets("Leads").Range("A1") <> "" Then
Set rngSource = Sheets("Leads").Range("A1").CurrentRegion
lastrowdyn = rngSource.Rows.Count
If lastrowdyn > 0 Then
Sheets("Leads").Range("A:A").Copy
Sheets("TempDataNew").Range ("A" & x)
Set rngSource = Sheets("TempDataNew").Range("A1").CurrentRegion
x = lastrowdyn + 1
End If
End If
I am getting the "Application Defined or Object Defined Error" when the code is trying to paste. Any thoughts?
From what I can tell, you want to copy to the bottom of the used range of TempDataNew, not Leads. So change this
Set rngSource = Sheets("Leads").Range("A1").CurrentRegion
to this
Set rngSourceTempDatNew = Sheets("TempDatNew").Range("A1").CurrentRegion
lastrowdynTempDatNew = rngSourceTempDatNew.Rows.Count
Also, I'm guessing you really don't want or need to copy the entire column A of Leads. So this needs to be changed.
Sheets("Leads").Range("A:A").Copy
or that is exactly what you'll end up doing. May I recommend also finding the last row of the used range in column A of Leads as you want to do for TempDatNew. Maybe something like
Set rngSourceLeads = Sheets("Leads").Range("A1").CurrentRegion
Now just copying from the range in Leads to the right spot in TempDatNew can be done with something like this
rngSourceLeads.Copy _
destination:=Worksheets("TempDatNew").Range("A" & lastrowdynTempDatNew + 1)
I can't exactly tell why you are storing the last row plus one to x, but my current thinking is that it isn't needed for your purposes. Every time this code is ran, it will update the last row of TempDatNew for you and you just simply paste in the row after that.
So, all together you have something more succinct and accurate with
If Sheets("Leads").Range("A1") <> "" Then
Set rngSourceTempDatNew = Sheets("TempDatNew").Range("A1").CurrentRegion
lastrowdynTempDatNew = rngSourceTempDatNew.Rows.Count
Set rngSourceLeads = Sheets("Leads").Range("A1").CurrentRegion
rngSourceLeads.Copy destination:=Worksheets("TempDatNew").Range("A" & lastrowdynTempDatNew + 1)
End If
EDIT
If you only want to copy column A in "Leads" change this
Set rngSourceLeads = Sheets("Leads").Range("A1").CurrentRegion
to this
lastrowdynLeads = Sheets("Leads").Cells(65000, 1).End(xlup).Row
Set rngSourceLeads = Sheets("Leads").Range("A1:A" & lastrowdynLeads)
This assumes you have no data below row 65000 in column A in sheet "Leads".
You have not specified what x is before you begin running the code. I have added a line to give x a value. The way you had it, excel was evaluating x to be 0, thus resulting in a range called Range("A0")... that doesn't exist.
If Sheets("Leads").Range("A1") <> "" Then
Set rngSource = Sheets("Leads").Range("A1").CurrentRegion
lastrowdyn = rngSource.Rows.Count
x = 1 'Whatever integer it is supposed to start at
If lastrowdyn > 0 Then
Sheets("Leads").Range("A:A").Copy
Sheets("TempDataNew").Range ("A" & x)
Set rngSource = Sheets("TempDataNew").Range("A1").CurrentRegion
x = lastrowdyn + 1
End If
End If
I think I found the problem you were originally experiencing in your code... Your first IF statement says If Sheets("Leads").Range("A1") <> "" Then. Your referencing a range object, and comparing it to a value. Your error should go away if you use Sheets("Leads").Range("A1").Value <> "".
I'm not sure why you want to use .CurrentRegion if you're only working with a single column (I'm also not the most versed in VBA logic) but if you're just trying to find the last row, you could use something like this:
Dim Leads, TempDataNew as Worksheet
Set Leads = ThisWorkbook.Sheets("Leads")
Set TempDataNew = ThisWorkbook.Sheets("TempDataNew")
lastrowdyn = Leads.Cells(Leads.Rows.Count, "A").End(xlUp).Row
If Leads.Range("A1").Value <> "" And lastrowdyn > 0 Then
Leads.Range("A:A").Copy Destination:=TempDataNew.Range("A" & x)
x = lastrowdyn + 1
End If
Why not just this?
Sub CopyRange()
Dim wsLeads As Worksheet, wsTemp As Worksheet
Dim lLastRowNew As Long, lRows As Long, iColumns As Integer
Set wsLeads = Worksheets("Leads")
Set wsTemp = Worksheets("TempDataNew")
lLastRowNew = wsTemp.UsedRange.Rows(wsTemp.UsedRange.Rows.Count).Row
lRows = wsLeads.UsedRange.Rows.Count
iColumns = wsLeads.UsedRange.Columns.Count
If wsLeads.Range("A1").Value <> "" And lRows > 0 Then
wsTemp.Cells(lLastRowNew + 1, 1).Resize(lRows, iColumns).Value = wsLeads.UsedRange.Value
End If
End Sub