Solved: find match copy cells to offset

[mperrah]

I'm trying to update 2 sheets with find and match and offset,
depending on several options...

I have a sub to add the receivers to inventory
"inventory" is worksheet("Receivers")
I invoice them out to remove them from inventory.
if the receiver is not used, it gets returned to inventory.
Sometimes though a receiver might go to another tech,
not back to inventory.

I have 5 rows of in a static location on Worksheets("Input")
3 cells are data validation
I14 is the tech from, I15 is the location to (tech or warehouse)
I16 is the reason, I17 is the Date
Rows I18 to I28 are items that will transfer (receivers)

If I15 = "1000 warehouse" then the items need to get added to the receiver sheet so it can be re-invoiced later
The number scanned will need to pull 3 other numbers from the recon sheet to re-populate the "Receiver" sheet
if the the value is anything other than "1000 Warehouse"
it needs to modify the offset of the match item I18 to I28 found on worksheets("Recon") rows D2 to end.

This is how I add receivers...
Sub AddRcvr()
Dim rcvrWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range

myCopy = "D7,D8,D9,D6"
Set inputWks = Worksheets("Input")
Set rcvrWks = Worksheets("Receivers")
With rcvrWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
Set myRng = .Range(myCopy)
If Application.CountA(myRng) <> myRng.Cells.Count Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With rcvrWks
oCol = 1
For Each myCell In myRng.Cells
rcvrWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With

'clear input cells that contain constants
With Sheets("Input")
[D7, D8, D9].ClearContents
[D7].Select
End With
End Sub

This is how I modify the "Recon" sheet if a receiver is DOA or installed:
Sub rcvr_Inst_DOA()

Dim rng As Range
Dim rng2 As Range
Dim cell As Range
Dim cell2 As Range
Dim sh_source As Worksheet
Dim sh_dest As Worksheet
Dim i As Long
Dim rcvr As Range

Set sh_source = Worksheets("Input")
Set sh_dest = Worksheets("Recon")

'If nothing present at invoice sheet on first line
If sh_source.Range("D18") = vbNullString Then Exit Sub

'search on receiverno (unique ?)
Set rng = sh_source.Range("D18:D" & _
sh_source.Range("D" & Rows.Count).End(xlUp).Row)
Set rng2 = sh_dest.Range("D2:D" & _
sh_dest.Range("D" & Rows.Count).End(xlUp).Row)

'loop for the invoice
For Each cell In rng
'loop for the receiver
For Each cell2 In rng2
If cell.Text = cell2.Text Then
With sh_dest.Range("D" & cell2.Row)
.Offset(0, 10) = sh_source.[D14] ' Tech Number col(O)
.Offset(0, 11) = sh_source.[D15] ' Cust Name col(P)
.Offset(0, 12) = sh_source.[D16] ' Job Number col(Q)
.Offset(0, 13) = sh_source.[D17] ' Install Date col(R)

End With
Exit For
End If
Next cell2
Next cell
With Worksheets("Input")
[D14:D28].ClearContents
[D14].Select
End With
End Sub

This is how I remove the parts with an Invoice:
Sub RemRcvr()

Dim rng As Range
Dim rng2 As Range
Dim cell As Range
Dim cell2 As Range
Dim sh_start As Worksheet
Dim sh_dest As Worksheet
Dim i As Long
Dim rcvr As Range
Dim r As Double
Dim lrowRcvr As Long

Set sh_start = Worksheets("Invoice")
Set sh_dest = Worksheets("Receivers")
'If nothing present at invoice sheet on first line
If sh_start.Range("G6") = vbNullString Then Exit Sub
'search on receiverno (unique ?)
Set rng = sh_start.Range("G6:G" & _
sh_start.Range("G" & Rows.Count).End(xlUp).Row)
Set rng2 = sh_dest.Range("A2:A" & _
sh_dest.Range("A" & Rows.Count).End(xlUp).Row)
'loop for the invoice
For Each cell In rng
'loop for the receiver
For Each cell2 In rng2
If cell.Text = cell2.Text Then
'Remove name of receiver
' sh_dest.Range("A" & cell2.Row).ClearContents
sh_dest.Range("A" & cell2.Row).Resize(1, 4).ClearContents
Exit For
End If
Next cell2
Next cell

lrowRcvr = sh_dest.Cells(Rows.Count, 1).End(xlUp).Row

sh_dest.Range("A2:F" & lrowRcvr).Sort Key1:=sh_dest.Range("D2"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

r = 0
With sh_dest
For i = 2 To lrowRcvr
If .Range("F" & i).Value = "" Then

ElseIf .Range("F" & i).Value > 0 And .Range("F" & i).Value < 16 Then
r = r + 1
ElseIf .Range("F" & i).Value >= 16 Then

End If
Next i
End With
With Worksheets("Receivers").Columns(8).Rows(1)
.Value = r
End With
End Sub

I need to do parts of each of these in one step.
1. Check if the receiver goes to stock or to a tech
2. If to stock, get the 3 numbers to the right of the match on the "Recon" sheet, and copy them to "Receivers"
3. If to tech, Find the match on "Recon" and add the cells to the offset, like the Installed or DOA sub does.

Any help would be appreciated...
Thanks in advance.
Mark

[mperrah]

Here is the file I have so far.
vbe password is james1

[mperrah]

I have most of the pieces working.
Wondered if I can call a sub and start within at a goto: spot?
The piece I still need help with is adding a entry to the recon
to show a new tech has ownership of a transfered receiver.
The original row gets amended, stating what tech got it
but I need a new row made for the new tech to track where the receiver ends up (installed, DOA, returned, or tranfered)
an issue is duplicate handling,
a single unique receiver could be invoiced, returned unsed,
reinvoiced, transfered, installed, and even later DOA

Maybe if I add a status column with 4 states to the recon sheet...
returned, transfered, installed, DOA

if its returned it gets reinserted to the receiver sheet. the recon appends the original entry
if its transfered, a new recon entry shows new owner and appends the latest entry with a match showing the transfer
if DOA or installed, the original entry just gets appended.
Now new entries needed

Here's what I have so far...

Sub rcvrTxfr()

Dim rng As Range
Dim rng2 As Range
Dim cell2 As Range
Dim sh_source As Worksheet
Dim sh_dest As Worksheet
Dim i As Long
Dim rcvr As Range
Dim trgtTo As Range
Dim trgtFrm As Range
Set sh_source = Worksheets("Input")
Set sh_dest = Worksheets("Recon")
Set trgtTo = sh_source.Range("I15")
Set trgtFrm = sh_source.Range("I14")

'If nothing present at invoice sheet on first line
If trgtFrm = vbNullString Then Exit Sub
If Not trgtTo = "1000 Warehouse" Then

returned:
'search on receiverno (unique ?)
i = o
Set rng = sh_source.Range("I18")
Set rng2 = sh_dest.Range("D2:D" & _
sh_dest.Range("D" & Rows.Count).End(xlUp).Row)

'loop for the receiver
For Each cell2 In rng2
If rng = cell2.Text _
And cell2.Offset(0, 10).Value = "" Then
With sh_dest.Range("D" & cell2.Row)
.Offset(0, 10) = sh_source. ' Tech From col(O)
.Offset(0, 11) = sh_source.[I15] ' Tech To col(P)
.Offset(0, 12) = sh_source.[I16] ' Reason col(Q)
.Offset(0, 13) = sh_source.[I17] ' Install Date col(R)

End With
i = i + 1
End If

If i > 1 Then
MsgBox "Duplicate entries for this receiver on Recon", , "Receiver cannot be Transfered"
Exit Sub
End If

Next cell2

End If

With Worksheets("Input")
[I18:I21].ClearContents
[I18].Select
End With

'call add recon
End Sub

Sub rcvrReturn()

Dim rng As Range
Dim rng2 As Range
Dim cell2 As Range
Dim sh_source As Worksheet
Dim sh_dest As Worksheet
Dim trgtTo As Range
Dim trgtFrm As Range
Dim rcvrWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range

Set sh_source = Worksheets("Input")
Set sh_dest = Worksheets("Recon")
Set trgtTo = sh_source.Range("I15")
Set trgtFrm = sh_source.Range("I14")
Set inputWks = Worksheets("Input")
Set rcvrWks = Worksheets("Receivers")

'If nothing present at invoice sheet on first line
If trgtFrm = vbNullString Then Exit Sub
If trgtTo = "1000 Warehouse" Then

Set rng = sh_source.Range("I18")
Set rng2 = sh_dest.Range("D2:D" & _
sh_dest.Range("D" & Rows.Count).End(xlUp).Row)

'loop for the receiver
For Each cell2 In rng2
If rng = cell2.Text Then
With sh_source.Range("I21")
.Value = cell2.Offset(0, 3).Text ' rcvr original received date from recon

End With
End If
Next cell2

myCopy = "I18,I19,I20,I21"
With rcvrWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
Set myRng = .Range(myCopy)
If Application.CountA(myRng) <> myRng.Cells.Count Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With rcvrWks
oCol = 1
For Each myCell In myRng.Cells
rcvrWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With

End If

Call rcvrTxfr [I]goto returned: 'is there something like this?

'call addrecon - need to debug
End Sub

[mperrah]

If i use a button that uses a case select,
how can I test 2 or 3 cells to evaluate the case,

case select
case if not I14 is nothing AND if I15 is "1000 Warehouse"
call return 'appendRecon
call replaceRcvrInv 'find match in recon, get orig rcv date
case if not I14 is nothing AND if Not I15 is "1000 Warehouse"
call trxfrRcvr
call appendRecon
End case select

[mperrah]

I found some help searching the forum and got most of my questions answered, and thought I'd post my work...
I still would like to set up a case select for the receiver status.
using five cases: ontruck, returned, DOA, Installed, Transfered.

I'll keep diggin for that.

The part that eludes me is when a tech returns a receiver,
I need to see if the item exists on the Recon sheet, and if the value offset(0, 10) is blank, then run code,
but if the cells on the input sheet are not all filled in,
exit sub and prompt to fill in data.
I'm not catching the missing data at the right time.
The message pops up, but after part of the sub has ran...
I have just been starring at it to long,
Any fresh eyes would be appreciated,

The sub is in modInput module,
under rcvrReturn()

Thanks in advance
Mark

[mperrah]

Got the copying working, may need a new thread for this idea...
Trying to stop house calls when a formula gets removed.
I noticed on my receiver sheet, if I add contents in column D,
column e adds the formula automatically.
This is a part of excel 2007 (awesome,
however, I also have a formula in F that does not get filled down.
This code is an attempt.
Any ideas (this doen't seem to do anything..

Private Sub Worksheet_Change(ByVal Target As Range)
Dim formulaFix As Range
Dim lRow As Long
lRow = Worksheets("Receivers").Range("A2:A" & Rows.Count).End(xlUp).Row
Set formulaFix = Worksheets("Receivers").Range("E2:E" & lRow)
If Target.Row > 1 And Target.Column = 1 Then
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, formulaFix) Is Nothing Then
With Worksheets("Receivers")
.Range("E2").Formula = "=IF(D2="""","""",D2+30)"
.Range("E2:E" & lRow).FillDown
.Range("F2").Formula = "=IF(A2="""","""",IF(30-(TODAY()-D2)<=15,30-(TODAY()-D2),""""))"
.Range("F2:F" & lRow).FillDown
End With
ElseIf Target.Value = "" Then
End If
End If
End Sub

[XLGibbs]

I noticed your flying solo on this, and other than your posting updates..have you run into an issue that requires some assistance? Perhaps a specific problem instead of the whole ball-o-wax approach?

[Aussiebear]

I noticed your flying solo on this, and other than your posting updates..have you run into an issue that requires some assistance? Perhaps a specific problem instead of the whole ball-o-wax approach?

hehehehe... He's baaaaack!

[XLGibbs]

hehehehe... He's baaaaack!

I am just passing by. I figure the wreckage I leave behind will keep xld, mdmack, and lucas busy for a few more months.:whistle:

[lucas]

If our biggest problem was you pointing out the obvious Pete........we wouldn't have much to do....:yes
Glad you are dropping by once in a while...

[XLGibbs]

If our biggest problem was you pointing out the obvious Pete........we wouldn't have much to do....:yes
Glad you are dropping by once in a while...

Ouch. I think.:dot:

[mperrah]

thanks xlgibbs
I thought no body liked me anymore...
I have learned alot from this forum. I've tried others but none compare
I use this vbax exclusively now.
I am getting better at digging for the pieces I need but still hit bumps in the road during development.

I pretty much got my project where I'm happy with it,
but I find the end user causing problems due to accidental deletions.

How do I lock a cells formula, but allow calculations to take place and update the values the formula is to generate within the locked cell?
If no can do, can I run a sub based on a target cell being deleted.
My last post shows an attempt to find when a cell in the target range gets deleted, and recopies the formula in the top cell and fills down to the last row which column A is not empty.
I thought I had part of it when column E would autopopulate when a value was entered in column D, but I disabled my sub and it still worked (a default option in excel 2007 was doing the job)

Well, copying a formula in a cell and fill down to the last row on worksheet change is what I need help with.
Also, I have a formula in E and F that both need to avoid deletion
And if I add something in the last row of A the formulas in E and F
need to auto populate.
Thanks for checking on me.
Mark

[XLGibbs]

You can protect the worksheet (or parts of it) which will prevent manual changes to the cell (calculation can still occur).

for copying a formula down, do a search on the board of "Autofill"

there are lots of snippets around here that show you how to do a SheetChange event which can populate the E/F formula when a new row is added.

Unless you post code that isn't working properly, it is kind of hard to give any specific answeres.

[mperrah]

This is what I have picked apart from other posts to try the autofill and worksheet change, not working though.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim formulaFix As Range
Dim lRow As Long
lRow = Worksheets("Receivers").Range("A2:A" & Rows.Count).End(xlUp).Row
Set formulaFix = Worksheets("Receivers").Range("E2:E" & lRow)
If Target.Row > 1 And Target.Column = 1 Then
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, formulaFix) Is Nothing Then
With Worksheets("Receivers")
.Range("E2").Formula = "=IF(D2="""","""",D2+30)"
.Range("E2:E" & lRow).FillDown
.Range("F2").Formula = "=IF(A2="""","""",IF(30-(TODAY()-D2)<=15,30-(TODAY()-D2),""""))"
.Range("F2:F" & lRow).FillDown
End With
ElseIf Target.Value = "" Then
End If
End If
End Sub

[lucas]

Ouch. I think.:dot:

It wasn't meant to be a dig Pete....sorry if I was unclear..:beerchug:

[XLGibbs]

You don't need to fill down. This will add those formulas to Col E and Col F when Col A value is changed.


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 then exit sub
If Target.Column = 1 Then
With Target
.Offset(, 4).Formula = "=IF(D" & .Row & "="""","""",D" & .Row & "+30)"
.Offset(, 5).Formula = "=IF(A" & .Row & "="""","""",IF(30-(TODAY()-D" & .Row & ")<=15,30-(TODAY()-D" & .Row & "),""""))"
End With
End If


End Sub

[XLGibbs]

It wasn't meant to be a dig Pete....sorry if I was unclear..:beerchug:

Nope, maybe you were just stating the obvious.

:drunkard:

[mperrah]

Man you make it seem so easy.
That works awesome.
Sorry if my posts have been long winded.
I have read many that leave many questions by people trying to help.
I thought defining all I have would get the desired results quicker.
I guess it just took bite size pieces... and you
Thank you so much..
Mark

[XLGibbs]

Man you make it seem so easy.
That works awesome.
Sorry if my posts have been long winded.
I have read many that leave many questions by people trying to help.
I thought defining all I have would get the desired results quicker.
I guess it just took bite size pieces... and you
Thank you so much..
Mark

Nope, just lots of experience dealing with management. Happy to help where i can.