Find Value And Copy Related Values

barbaar · May 21st 2008

Right now I am building a Macro which can be found underneath. The red code is not working right now and I am looking for alternatives to solve this error but until now I haven't found none.

Basically, I am looking for a correct code to copy files from a sheet to another sheet with a find macro.

Code

Sub vinden()
    Dim FindString As String
    Dim Rng As Range
    FindString = Range("A21")
    If Trim(FindString) <> "" Then
        With Sheets("Voorraadverloop").Range("A1:IV65536")
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True
[COLOR="Red"]                LR = Worksheets("Voorraadverloop").Cells(Rows.Count, 1).End(xlUp).Row + 2
     With Sheets("Voorraadscherm")
    .Cells(LR, 1) = Sheets("Voorraadscherm").Cells(4, 1)
    .Cells(LR, 3) = Sheets("Voorraadscherm").Cells(4, 3)
    .Cells(LR, 5) = Sheets("Voorraadscherm").Cells(4, 5)[/COLOR]
End With
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
End Sub

Display More

**Ger Plante** · May 21st 2008

Re: Find Value And Copy Related Values

Quote

The red code is not working right now

Specifically - what isnt working - what is the error? What is not happening?

Quote

Basically, I am looking for a correct code to copy files from a sheet to another sheet with a find macro.

The code you showed in the macro does not copy files, it copies the contents of cells from row 4 column 1, 3 and 5 of sheet "Voorraadscherm" to row "X" on sheet "Voorraadscherm" (i.e. the same sheet).

Row X is 2 rows beyond the last row that contains data in Column A on Sheet "Voorraadverloop".

Other than that, I dont know what you are doing / what you expect to happen / how you expect your code to achieve that / what is wrong with your code.

Take care,
Ger

Robert B · May 21st 2008

Re: Find Value And Copy Related Values

Hi

you don't seem to have declared LR as Long

HTH

Robert

barbaar · May 21st 2008

Re: Find Value And Copy Related Values

The function of this macro is to find cell "A21" from the sheet "voorraadscherm" in the sheet "Voorraadverloop". When this cell is found, the macro should copy the contents from the cells "A21, C21 and E21" from the sheet "voorraadscherm" to the first available row in the sheet "Voorraadverloop". I've made a little screenshot of the purpose of the macro.

[Blocked Image: http://i25.tinypic.com/2mz2bq.jpg]

The code will be something like this then, but it still doesn't work.

Code

Sub PlaatsingVoorraadverloop()
    Dim FindString As String
    Dim Rng As Range
    Dim Lr As Long
        FindString = Range("A21")
    If Trim(FindString) <> "" Then
        With Sheets("Voorraadverloop").Range("A1:IV65536")
            Set Rng = .Find(What:=FindString, _
            After:=.Cells(.Cells.Count), _
            LookIn:=xlValues, _
            LookAt:=xlWhole, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, _
            MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True
                    Lr = Worksheets("Voorraadverloop").ActiveCell.End(xlDown).Row + 2
                With Sheets("Voorraadverloop")
                    .Cells(Lr, 1) = Sheets("Voorraadscherm").Cells(21, 1)
                    .Cells(Lr, 3) = Sheets("Voorraadscherm").Cells(21, 3)
                    .Cells(Lr, 5) = Sheets("Voorraadscherm").Cells(21, 5)
                End With
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
End Sub

Display More

The error I get is nr. 438: The property or method isn't supported by this object. The error emerges when it reaches this piece of code: Lr = Worksheets("Voorraadverloop").ActiveCell.End(xlDown).Row + 2

I hope I made myself a little bit more clear. Since English isn't my native language, it's a bit harder for me to explain what I try to do. If you still got some questions, please ask them, I will be glad to anwser them if that will solve my problem

Regards,

Barbaar

Robert B · May 21st 2008

Re: Find Value And Copy Related Values

Hi

I think if you replace

Code

Lr = Worksheets("Voorraadverloop").ActiveCell.End(xlDown).Row + 2

with

Code

Lr = ActiveCell.End(xlDown).Row + 2

that will give you the value you need for Lr, assuming you are running the macro with Voorraadverloop as the active sheet.

HTH

Robert

barbaar · May 21st 2008

Re: Find Value And Copy Related Values

Thnx, that's almost it! :grin:

There is only one more thing needed to solve this problem.

If productnummer (cell A21 in sheet "Voorraadscherm") is 456, the macro should copy the contents of Cells from row 4 column 1, 3 and 5 of sheet "Voorraadscherm" to the designated area in the sheet "voorraadverloop".

I have tried to solve this before, but I keep failing on solving this problem. I hope you can help me with this part too. If so, you really made my day/week/year!

Thnx for all the support so far guys! Much appreciated!

barbaar · May 22nd 2008

Re: Find Value And Copy Related Values

bumperdebump

Robert B · May 23rd 2008

Re: Find Value And Copy Related Values

Hi
try replacing this sequence

Code

.Cells(Lr, 1) = Sheets("Voorraadscherm").Cells(21, 1) 
                   .Cells(Lr, 3) = Sheets("Voorraadscherm").Cells(21, 3) 
                    .Cells(Lr, 5) = Sheets("Voorraadscherm").Cells(21, 5)

with this

Code

dim SourceCell as Range,TargetCell as Range
Set TargetCell = Sheets("Voorraadverloop").Range("A" & LR)
set SourceCell = Sheets("Voorraadscherm").Range("A21")
SourceCell .Copy Destination:= TargetCell
SourceCell.Offset(0,2) .Copy Destination:= TargetCell.Offset(0,2)
SourceCell.Offset(0,4) .Copy Destination:= TargetCell.Offset(0,4)

I am not certain that the construct .Cells(n,n) is valid. If you are defining a cell within a declared range, the form .Cells(n) is usually OK

HTH

Robert

barbaar · May 26th 2008

Re: Find Value And Copy Related Values

I received another solution for this problem. This is the following code:

Code

Sub PlaatsingVoorraadverloop()
Dim iRij, iBR As Integer
    iBR = 21
    With Worksheets("Voorraadverloop").Range("A1:IV10")
        Set P = .Find(Worksheets("Voorraadscherm").Range("A21").Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not P Is Nothing Then
            iRij = Worksheets("Voorraadverloop").Cells(P.Row, P.Column).End(xlDown).Row + 1
            While Worksheets("Voorraadscherm").Cells(iBR, "A").Value <> ""
                Worksheets("Voorraadverloop").Cells(iRij, P.Column).Value = Worksheets("Voorraadscherm").Range("A" & iBR).Value
                Worksheets("Voorraadverloop").Cells(iRij, P.Column + 2).Value = Worksheets("Voorraadscherm").Range("C" & iBR).Value
                Worksheets("Voorraadverloop").Cells(iRij, P.Column + 4).Value = Worksheets("Voorraadscherm").Range("E" & iBR).Value
                iBR = iBR + 1
                iRij = iRij + 1
            Wend
        End If
    End With
End Sub

Display More

I now want to use this code for multiple cells. They are shown on the image I provided some posts above. It's the table within the range of A4-I13. Any of you guys know how to bend this macro in the correct way for this purpose? I tried too, but I failed

The code I have right now is this:

Code

Private Sub CommandButtonBinnen1_Click()
Dim iRij, iBR As Integer
If CheckBox1.Value = True Then
    iBR = 4
If Worksheets("Voorraadscherm").Range("A4") = "" Then
CheckBox1.Value = False
Else
If Application.WorksheetFunction.CountA(Range("A4:H4")) < 8 Then
MsgBox ("Niet volledig ingevuld"): Exit Sub
End If
Lr = Worksheets("Inkoopscherm").Cells(Rows.Count, 1).End(xlUp).Row + 1
For iKol = 1 To 8
        Sheets("Inkoopscherm").Cells(Lr, iKol) = Sheets("Voorraadscherm").Cells(4, iKol)
Next
While Worksheets("Voorraadscherm").Cells(iBR, "A").Value <> ""
    With Worksheets("Voorraadverloop").Range("A1:IV10")
        Set P = .Find(Worksheets("Voorraadscherm").Cells(iBR, "A").Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not P Is Nothing Then
            iRij = Worksheets("Voorraadverloop").Cells(P.Row, P.Column).End(xlDown).Row + 1
                Worksheets("Voorraadverloop").Cells(iRij, P.Column).Value = Worksheets("Voorraadscherm").Range("A" & iBR).Value
                Worksheets("Voorraadverloop").Cells(iRij, P.Column + 2).Value = Worksheets("Voorraadscherm").Range("C" & iBR).Value
                Worksheets("Voorraadverloop").Cells(iRij, P.Column + 4).Value = Worksheets("Voorraadscherm").Range("E" & iBR).Value
                iBR = iBR + 1
                iRij = iRij + 1
        End If
    End With
Wend
CheckBox1.Value = False
    Sheets("Voorraadscherm").Range("A4:H4").ClearContents
End If
End If
If CheckBox2.Value = True Then
    iBR = 5
If Worksheets("Voorraadscherm").Range("A5") = "" Then
CheckBox2.Value = False
Else
If Application.WorksheetFunction.CountA(Range("A5:H5")) < 8 Then
MsgBox ("Niet volledig ingevuld"): Exit Sub
End If
Lr = Worksheets("Inkoopscherm").Cells(Rows.Count, 1).End(xlUp).Row + 1
For iKol = 1 To 8
        Sheets("Inkoopscherm").Cells(Lr, iKol) = Sheets("Voorraadscherm").Cells(5, iKol)
Next
    With Worksheets("Voorraadverloop").Range("A1:IV10")
        Set P = .Find(Worksheets("Voorraadscherm").Range("A5").Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not P Is Nothing Then
            iRij = Worksheets("Voorraadverloop").Cells(P.Row, P.Column).End(xlDown).Row + 1
            While Worksheets("Voorraadscherm").Cells(iBR, "A").Value <> ""
                Worksheets("Voorraadverloop").Cells(iRij, P.Column).Value = Worksheets("Voorraadscherm").Range("A" & iBR).Value
                Worksheets("Voorraadverloop").Cells(iRij, P.Column + 2).Value = Worksheets("Voorraadscherm").Range("C" & iBR).Value
                Worksheets("Voorraadverloop").Cells(iRij, P.Column + 4).Value = Worksheets("Voorraadscherm").Range("E" & iBR).Value
                iBR = iBR + 1
                iRij = iRij + 1
            Wend
        End If
    End With
CheckBox2.Value = False
    Sheets("Voorraadscherm").Range("A5:H5").ClearContents
End If
End If


etc etc...

Display More

thnx in advance

Dave Hawley · May 26th 2008

Re: Find Value And Copy Related Values

Quote

I received another solution for this problem

Where from?

Find Value And Copy Related Values

Participate now!

Share