Transfer selected rows to sheet

Transfer selected rows to sheet

--------------------------------------------------------------------------------

Dim MyValue As Variant
Dim FromSheet As Worksheet
Dim LookupColumn As Integer
Dim FromRow As Long
Dim FromColumn As Integer
'-
Dim ToSheet As Worksheet
Dim StartRow As Long
Dim LastRow As Long
Dim ActiveColumn As Integer
Dim ReturnColumnNumber
Dim ToRow As Long
Dim FoundCell As Object

'================================================= ============
'- MAIN ROUTINE
'================================================= ============
Sub DO_LOOKUP()
Application.Calculation = xlCalculationManual
'----------------------------------------------------------
'- LOOKUP SHEET [**AMEND AS REQUIRED**]
Set FromSheet = Workbooks("Book1.xls").Worksheets("MD")
LookupColumn = 2 ' look for match here
FromColumn = 2 ' return value from here
'-----------------------------------------------------------
'- ACTIVE SHEET
Set ToSheet = ActiveSheet
ActiveColumn = ActiveCell.Column
StartRow = ActiveCell.Row
'-------------------------------------------------------------
'- COMMENT OUT UNWANTED LINE, UNCOMMENT THE OTHER
'- ..............................[** FOR MULTIPLE ROWS **]
LastRow = ToSheet.Cells(65536, ActiveColumn).End(xlUp).Row
'-
'- ..............................[** FOR A SINGLE VALUE **]
' LastRow = ActiveCell.Row
'-------------------------------------------------------------
'- COLUMN NUMBER TO PUT RETURNED VALUE [**AMEND AS REQUIRED**]
ReturnColumnNumber = 2 ' column number
'-------------------------------------------------------------
'- loop through each row (which may be only 1)
For ToRow = StartRow To LastRow
MyValue = ToSheet.Cells(ToRow, ActiveColumn).Value
FindValue
Next
'-------------------------------------------------------------
'- finish
MsgBox ("Done")
Application.Calculation = xlCalculationAutomatic
End Sub
'== END OF PROCEDURE ================================================== ==

'================================================= =======================
'- FIND VALUE
'================================================= =======================
Private Sub FindValue()
' Dim VendMat As String
' Dim matDesc As String
' Dim startDate As String
' Dim BUN As String
Set FoundCell = _
FromSheet.Columns(LookupColumn).Find(MyValue, LookIn:=xlValues)
If FoundCell Is Nothing Then
MsgBox ("Material No. " & MyValue & " not found in Master List.")
'Paste this value to MD
'-----
' VendMat = Sheets("Sheet1").Select
' VendMat = Range("C65536").End(xlUp).Offset(0, 0).Select
'VendMat = Selection.Copy
'------

Sheets("MD").Select
Range("B:B").Select

Range("B65536").End(xlUp).Offset(1, 0).Select
IsEmpty (ActiveCell)
ActiveCell = MyValue

' Sheets("MD").Select
' Range("C:C").Select
' Range("C65536").End(xlUp).Offset(1, 0).Select
' IsEmpty (ActiveCell)
' ActiveCell.Select = VendMat
' ActiveCell = VendMat

'---------------------------------------------

Else
FromRow = FoundCell.Row
'- transfer additional data.
ToSheet.Cells(ToRow, ReturnColumnNumber).Value = _
FromSheet.Cells(FromRow, FromColumn).Value
End If
End Sub
'

This works fine in detecting and copying the new material number accross to the master data sheet, but now i want it to copy the row in which the new material number is located as there is other information that goes with so it doesn't have to be manually typed in.

TIA

"vect98" <[email protected]> wrote in
message news:[email protected]...
>
> Transfer selected rows to sheet

Example:
You have data in A10:E20
You want to look for an item which can be located in
column A.
Suppose it's found at A12, then you want le entire
record A12:E12 be appended to the range K40:N120, at
the first free record, suppose K109:N109.
You want to have in the program the source range A10:E20
and the target range K40:N120 as code parameters.
Then for each operation you want to supply only the
item's name/code.

Is it ok?
Bruno

Bruno,

That 's the problem that i've met now - could you please write down a simple solution to the situation you mention?

Thanks,

Chris

"chris100" <[email protected]> wrote in
message news:[email protected]...
>
> Bruno,
>
> That 's the problem that i've met now - could you please write down a
> simple solution to the situation you mention?

Here is quite a simple code.
Define how many columns involved (n), together with
source and target top left cells (SourceRange, TargetRange).
Let me know if you need any changes, or if you find
any bugs.

==========================================
Sub Button18_Click()
Dim SourceRange As Range, TargetRange As Range
Dim SearchRange As Range, LastWrittenCell As Range
Dim i, n As Integer, ItemToSearchFor
'--------------------------------------
' User definitions
n = 5 ' number of columns to append
Set SourceRange = [AA10]
Set TargetRange = [AG10]
'--------------------------------------
Set SearchRange = Range(SourceRange, SourceRange.End(xlDown))
Set LastWrittenCell = TargetRange.End(xlDown)

ItemToSearchFor = InputBox("Item To Search For:" & vbCrLf & "(case
sensitive)")
If ItemToSearchFor = "" Then
Exit Sub
End If

For Each i In SearchRange
If i.Value = ItemToSearchFor Then
Range(i, i.Offset(0, n - 1)).Copy LastWrittenCell.Offset(1, 0)
End If
Next

End Sub

==============================================

Bruno

Hi Bruno,

Thanks for the help but i'm afraid i didn't explain myself properly.
Cell A1 contains criteria i need to search for in Column L (This is a date)
Any rows (say A to L row cells only) in Column L that contain the same date as Cell A1 need to be copied and pasted to 'SheetArchive.'

I tried manipulating the code you gave but i'm afraid i'm not very good at VBA for excel yet!

Thanks again for the help.

"chris100" <[email protected]> wrote in
message news:[email protected]...

> Hi Bruno,
>
> Thanks for the help but i'm afraid i didn't explain myself properly.
> Cell A1 contains criteria i need to search for in Column L (This is a
> date)
[...]

Well, A1 contains the date you want to search for,
column L contains a lot of dates.

When the date is found in column L (say at L12),
the cells A12, B12, C12, ... need to be copied
to the same cells (A12, B12, C12,...) of 'SheetArchive'.
Is it ok?

Another question:
If date from A1 is found in column L at more then one
cell, must all ranges be copied to 'ArchiveSheet'?
Or, does column L contain unique values (i.e. no duplicates)?

Bruno

Hi Bruno,

That's exactly what what trying to do...do you think you could write a simple code for that example that i can work with?

Thanks a bundle

When the date is found in column L (say at L12),
the cells A12, B12, C12, ... need to be copied
to the same cells (A12, B12, C12,...) of 'SheetArchive'.
Is it ok?

"chris100" <[email protected]> wrote in
message news:[email protected]...
>
> Hi Bruno,
>
> That's exactly what what trying to do...do you think you could write a
> simple code for that example that i can work with?

Yes, but tell me what/how many columns are involved
and if there are duplicates values in column L.

Bruno

Sorry - yep, there are 12 columns involved each containing different info such as stock, cost price, market price, product name etc. Of these 12 the only criteria is in column L. Column L contains differing dates for when a product arrived. The only info that needs to be copied are those pertaining to today() (which is in cell A1.)

e.g

PRODUCT PRICE STOCK DATE
APPLE 1.50 15 01/09/05
BANANA 2.00 0 31/08/05
CRANBERRY 1.20 55 24/08/05
DILL 3.50 10 01/09/05

So in this example, assuming todays date (note there would be 8 more columns in the middle) only the info for APPLE and DILL would be transferred over to the other worksheet. BANANA and CRANBERRY would already have been transferred on the 31/08 nad 24/08 respectively.

Let me explain what this is all for....

This forms part of a stock check and pricing system for a greengrocers. Products come in, checked against bills and an invoice produced. This part of the system above will archive any purchases made so that old bills could be checked. The reason i have to transfer over todays() info is so that the next day when a new item comes in, it forms the basis of the new price list. Hope that explains all this. I'm trying to learn VBA but at the moment i'm just piecing together the system with help from you guys (and gals). Who would have thought there was so much to selling a pound of spuds.....

Hi all,

I'm just bringing this up to the top of the list again because i really need help with this question. At the risk of sounding like i'm begging, please please please please with sugar on the top help!

"chris100" <[email protected]> wrote in
message news:[email protected]...
>
> Hi all,
>
> I'm just bringing this up to the top of the list again because i really
> need help with this question. At the risk of sounding like i'm begging,
> please please please please with sugar on the top help!

Sorry for delay Chris,
Try this sub and let me know if it's ok for you.
You must define n (number of columns),
SourceRange and TargetRange.
It overwrites duplicates in TargetRange.
If you have data in AA10:AE65536 and want to
append the result of search to AG10:AK65536
you must state:
n = 5
SourceRange = [AA10]
TargetRange = [AG10]
The routine will copy to AG10:AK65536 starting from
the first empty cell in column AG10:AG65536

========================================
Sub CopyRow()
Dim SourceRange As Range, TargetRange As Range
Dim SearchRange As Range, LastWrittenCell As Range
Dim i, n As Integer, k As Integer, ItemToSearchFor
'--------------------------------------
' User definitions
n = 5 ' number of columns to append
Set SourceRange = [AA10]
Set TargetRange = [AG10]
'--------------------------------------
Set SearchRange = Range(SourceRange, SourceRange.End(xlDown))
If IsEmpty(TargetRange) Then
Set LastWrittenCell = TargetRange
k = 0
Else
k = 1
If IsEmpty(TargetRange.Offset(1, 0)) Then
Set LastWrittenCell = TargetRange
Else
Set LastWrittenCell = TargetRange.End(xlDown)
End If
End If

ItemToSearchFor = InputBox("Item To Search For:" & vbCrLf & "(case
sensitive)")
If ItemToSearchFor = "" Then
Exit Sub
End If

For Each i In SearchRange
If i.Value = ItemToSearchFor Then
Range(i, i.Offset(0, n - 1)).Copy LastWrittenCell.Offset(k, 0)
End If
Next

End Sub
=====================================

Ciao
Bruno

Thanks for getting back bruno - i'll give that a go when i finish work and let you know.

Regards,

Chris

Hi Bruno,

I've been playing around with the script and am very near a solution. The only change that's needed is to account for the same criteria appearing twice (i explian below). This is the slightly adjusted script:

Sub CopyRow()
Dim SourceRange As Range, TargetRange As Range
Dim SearchRange As Range, LastWrittenCell As Range
Dim i, n As Integer, k As Integer, ItemToSearchFor
'--------------------------------------
' User definitions
n = 6 ' number of columns to append
Set SourceRange = [AA1]
Set TargetRange = Range("Sheet2!A1")
'--------------------------------------
Set SearchRange = Range(SourceRange, SourceRange.End(xlDown))
If IsEmpty(TargetRange) Then
Set LastWrittenCell = TargetRange
k = 0
Else
k = 1
If IsEmpty(TargetRange.Offset(1, 0)) Then
Set LastWrittenCell = TargetRange
Else
Set LastWrittenCell = TargetRange.End(xlDown)
End If
End If

ItemToSearchFor = [A1]
If ItemToSearchFor = "" Then
Exit Sub
End If

For Each i In SearchRange
If i.Value = ItemToSearchFor Then
Range(i, i.Offset(0, n - 1)).Copy LastWrittenCell.Offset(k, 0)
End If
Next

End Sub


The changes are:

Targetrange - adjusted to append to a different worksheet
itemtosearchfor = A1 'where date(now) is used

At the moment when there are several dates of the same value in the column, it will only append the last row of those dates. I need to append any rows which have the same date as cell A1. Could you please advise? I looked around but i'm afraid i don't know much about looping (and evidently everything else in VBA for that matter...)

Regards,

Chris

"chris100" <[email protected]> wrote in
message news:[email protected]...

[...]
> At the moment when there are several dates of the same value in the
> column, it will only append the last row of those dates. I need to
> append any rows which have the same date as cell A1. Could you please
> advise? I looked around but i'm afraid i don't know much about looping
> (and evidently everything else in VBA for that matter...)
>
> Regards,
>
> Chris

Ok Chris, only slight modifications: added another
counter (j) to the last For... Next.
Please rerrange as per your need as I worked on my
copy without following your modifications.

--------------------------------------------
Sub CopyRow()
Dim SourceRange As Range, TargetRange As Range
Dim SearchRange As Range, LastWrittenCell As Range
Dim i, n As Integer, k As Integer, j As Integer, ItemToSearchFor
'--------------------------------------
' User definitions
n = 5 ' number of columns to append
Set SourceRange = [AA10]
Set TargetRange = [AG10]
'--------------------------------------
Set SearchRange = Range(SourceRange, SourceRange.End(xlDown))
If IsEmpty(TargetRange) Then
Set LastWrittenCell = TargetRange
k = 0
Else
k = 1
If IsEmpty(TargetRange.Offset(1, 0)) Then
Set LastWrittenCell = TargetRange
Else
Set LastWrittenCell = TargetRange.End(xlDown)
End If
End If

ItemToSearchFor = InputBox("Item To Search For:" & vbCrLf & "(case
sensitive)")
If ItemToSearchFor = "" Then
Exit Sub
End If

For Each i In SearchRange
If i.Value = ItemToSearchFor Then
Range(i, i.Offset(0, n - 1)).Copy LastWrittenCell.Offset(k + j, 0)
j = j + 1
End If
Next

End Sub
-----------------------------------

Ciao
Bruno

"chris100" <[email protected]> wrote in
message news:[email protected]...

[...]
> At the moment when there are several dates of the same value in the
> column, it will only append the last row of those dates. I need to
> append any rows which have the same date as cell A1. Could you please
> advise? I looked around but i'm afraid i don't know much about looping
> (and evidently everything else in VBA for that matter...)
>
> Regards,
>
> Chris

Ok Chris, only slight modifications: added another
counter (j) to the last For... Next.
Please rerrange as per your need as I worked on my
copy without following your modifications.

--------------------------------------------
Sub CopyRow()
Dim SourceRange As Range, TargetRange As Range
Dim SearchRange As Range, LastWrittenCell As Range
Dim i, n As Integer, k As Integer, j As Integer, ItemToSearchFor
'--------------------------------------
' User definitions
n = 5 ' number of columns to append
Set SourceRange = [AA10]
Set TargetRange = [AG10]
'--------------------------------------
Set SearchRange = Range(SourceRange, SourceRange.End(xlDown))
If IsEmpty(TargetRange) Then
Set LastWrittenCell = TargetRange
k = 0
Else
k = 1
If IsEmpty(TargetRange.Offset(1, 0)) Then
Set LastWrittenCell = TargetRange
Else
Set LastWrittenCell = TargetRange.End(xlDown)
End If
End If

ItemToSearchFor = InputBox("Item To Search For:" & vbCrLf & "(case
sensitive)")
If ItemToSearchFor = "" Then
Exit Sub
End If

For Each i In SearchRange
If i.Value = ItemToSearchFor Then
Range(i, i.Offset(0, n - 1)).Copy LastWrittenCell.Offset(k + j, 0)
j = j + 1
End If
Next

End Sub
-----------------------------------

Ciao
Bruno

"chris100" <[email protected]> wrote in
message news:[email protected]...

[...]
> At the moment when there are several dates of the same value in the
> column, it will only append the last row of those dates. I need to
> append any rows which have the same date as cell A1. Could you please
> advise? I looked around but i'm afraid i don't know much about looping
> (and evidently everything else in VBA for that matter...)
>
> Regards,
>
> Chris

Ok Chris, only slight modifications: added another
counter (j) to the last For... Next.
Please rerrange as per your need as I worked on my
copy without following your modifications.

--------------------------------------------
Sub CopyRow()
Dim SourceRange As Range, TargetRange As Range
Dim SearchRange As Range, LastWrittenCell As Range
Dim i, n As Integer, k As Integer, j As Integer, ItemToSearchFor
'--------------------------------------
' User definitions
n = 5 ' number of columns to append
Set SourceRange = [AA10]
Set TargetRange = [AG10]
'--------------------------------------
Set SearchRange = Range(SourceRange, SourceRange.End(xlDown))
If IsEmpty(TargetRange) Then
Set LastWrittenCell = TargetRange
k = 0
Else
k = 1
If IsEmpty(TargetRange.Offset(1, 0)) Then
Set LastWrittenCell = TargetRange
Else
Set LastWrittenCell = TargetRange.End(xlDown)
End If
End If

ItemToSearchFor = InputBox("Item To Search For:" & vbCrLf & "(case
sensitive)")
If ItemToSearchFor = "" Then
Exit Sub
End If

For Each i In SearchRange
If i.Value = ItemToSearchFor Then
Range(i, i.Offset(0, n - 1)).Copy LastWrittenCell.Offset(k + j, 0)
j = j + 1
End If
Next

End Sub
-----------------------------------

Ciao
Bruno

This is an extension of the script above - i'll post the code first and then explain:

Dim SourceRange As Range, TargetRange As Range
Dim SearchRange As Range, LastWrittenCell As Range
Dim i, n As Integer, k As Integer, ItemToSearchFor
'--------------------------------------
' User definitions
n = 33 ' number of columns to append
Set SourceRange = [AF1]
Set TargetRange = Range("BILLSPAIDTEMP!E1")
'--------------------------------------
Set SearchRange = Range(SourceRange, SourceRange.End(xlDown))
If IsEmpty(TargetRange) Then
Set LastWrittenCell = TargetRange
k = 0
Else
k = 1
If IsEmpty(TargetRange.Offset(1, 0)) Then
Set LastWrittenCell = TargetRange
Else
Set LastWrittenCell = TargetRange.End(xlDown)
End If
End If

ItemToSearchFor = [AY1]
If ItemToSearchFor = "" Then
Exit Sub
End If

For Each i In SearchRange
If i.Value = ItemToSearchFor Then
Range(i, i.Offset(0, n - 1)).Copy LastWrittenCell.Offset(k + j, 0)
j = j + 1
End If
Next

MsgBox "PASTE SUCCESSFUL"

End Sub

The script works lovely - the problem is i need to append the 33 columns of info from columns A to AH. Using the method above, it appends 33 columns starting from AF. What adjustment do i need to make?

Thanks,

Chris

anyone had any ideas? i had to bring this to the top - desperately in need of help.