Transfer selected rows to sheet

V

vect98

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
 
B

Bruno Campanini

vect98 said:
Transfer selected rows to sheet
Click to expand...

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
 
C

chris100

Bruno,

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

Thanks,

Chri
 
B

Bruno Campanini

chris100 said:
Bruno,

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

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
 
C

chris100

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.
 
B

Bruno Campanini

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)
Click to expand...
[...]

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
 
C

chris100

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?
 
B

Bruno Campanini

chris100 said:
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?
Click to expand...

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

Bruno
 
C

chris100

Sorry - yep, there are 12 columns involved each containing differen
info such as stock, cost price, market price, product name etc. O
these 12 the only criteria is in column L. Column L contains differin
dates for when a product arrived. The only info that needs to be copie
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 mor
columns in the middle) only the info for APPLE and DILL would b
transferred over to the other worksheet. BANANA and CRANBERRY woul
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. Thi
part of the system above will archive any purchases made so that ol
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 th
basis of the new price list. Hope that explains all this. I'm tryin
to learn VBA but at the moment i'm just piecing together the syste
with help from you guys (and gals). Who would have thought there wa
so much to selling a pound of spuds....
 
C

chris100

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!
 
B

Bruno Campanini

chris100 said:
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!
Click to expand...

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
 
C

chris100

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

Regards,

Chri
 
C

chris100

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
 
B

Bruno Campanini

message
[...]
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
Click to expand...

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
 
B

Bruno Campanini

message
[...]
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
Click to expand...

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
 
B

Bruno Campanini

message
[...]
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
Click to expand...

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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Copying other column values when detected 5
Code not finding records 3
export excel data to access table using ADO 0
Macro to copy row based on value into new sheet of same name 9
Cut bottom 300 rows to next sheet & repeat 8
Move rows based on cell info 4
Copy filtered data to sheet 2 1
vlookup issue 2

Top