Transfer Value to another sheet with Macro

[EMoe]

Hello,

I have a list of 10 names on sheet1 in column A. Column B had monetar
values besides the names.

Sheet2 has those same names in column A. Row 1 uptop has dates space
apart every 7 days.

I need a macro to find a name from sheet1, look on sheet 2 for th
matching name, then place its value in the next empty column. Hit th
button again, and it places the value in the next column. See Exampl
below:

Sheet 1 (this week):

A B
1 Mark $50
2 Paul $25
3 Sally $15

Next Week things has changed...

Sheet1 (next week):

A B
1 Mark $20
2 Paul $80
3 Sally $35


Sheet 2 (which is the DataBase):

A B C
1 Mark $50 $20
2 Paul $25 $80
3 Sally $15 $35

Note: I should be able to add more names if necessary to the sheet

Thanks,
EMo

 

[Guest]

In my opinion you should re-evaluate how you want to do this. The path you
are going down will be problematic. My recomendation would be (as you even
suggest) to make this more like a database. Sheet 1 should be 3 columns
instead of two. New records will be appended to the end of the list. The
third column will be the date. You can then just create a pivot table on
sheet 2 referencing the source data on sheet 1. You will be able to get your
weeks across the top and the people down the side... No macros... Easy to
do...

 

[anilsolipuram]

Try this macro


Sub macro()
Dim i, name, monet As Variant
i = 2
Worksheets("Sheet1").Select
While Range("a" & i).Value <> ""
name = Range("a" & i).Value
monet = Range("b" & i).Value
Worksheets("Sheet2").Select
Columns("A:A").Select
On Error GoTo a:
Selection.Find(What:=name, After:=ActiveCell
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext
_
MatchCase:=False).Activate
temp = ActiveCell.Address
ActiveCell.Select
Selection.End(xlToRight).Select
If ActiveCell.Column = 256 Then
Range(temp).Offset(0, 1).Select
Else
ActiveCell.Offset(0, 1).Select
End If
ActiveCell.Value = monet
a:
If (Err.Description <> "") Then
Err.Clear
End If
Worksheets("Sheet1").Select
i = i + 1
Wend
End Su

 

[EMoe]

The code works well.

I see that it finds the next blank cell, then fills it. So if I ad
another name after about 5 transfers. It will add that amount to th
first blank cell, and not over to the 6th transfer column.

But it still works for me. I just fill the empty cells with 0'
(conditional formatted to white text color, so that they're invisible
so that the code goes to the correct column which has the correc
date.

Thanks,
EMo

 

[Don Guillett]

If you do want to do this, this will do it. It compensates for adding a
name, adds 7 days to the date, copies the values.

Sub copytolastcol()
With Sheets("yourdestinationsheetname")
Range("a2:a20").Copy .Range("a2")'copies names
lastcol = .Cells.SpecialCells(xlCellTypeLastCell).Column
..Cells(1, lastcol + 1) = .Cells(1, lastcol) + 7'adds date
For Each c In Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
x = .Columns(1).Find(c).Row
..Cells(x, lastcol + 1).Value = Cells(c.Row, 2)
Next
End With
End Sub

 

[EMoe]

Thanks for the reply!

Sub copytolastcol()
With Sheets("yourdestinationsheetname")
Range("a2:a20").Copy .Range("a2")'copies names
lastcol = .Cells.SpecialCells(xlCellTypeLastCell).Column
.Cells(1, lastcol + 1) = .Cells(1, lastcol) + 7'adds date
For Each c In Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
x = .Columns(1).Find(c).Row
.Cells(x, lastcol + 1).Value = Cells(c.Row, 2)
Next
End With
End Sub

Yes I really want to do this, with the option of adding new names. Whe
I run the code, I get "Compile error, Argument not optional, and exce
highlights lastcol =

I haven't a clue whats wrong. I placed the code in a module, as well a
in This Workbook. Still not working.

EMo

 

[William Benson]

I thought you needed a "." in front of any objects which have a parent = to
the item you referenced using "With"

Sorry if not helpful, I am sure someone will be more helpful.

 

[Don Guillett]

this is what I TESTED and sent with all .'s in the right place. Have no idea
why some were deleted?

Sub copytolastcol()
With Sheets("sheet2")
Range("a2:a10").Copy .Range("a2")
lastcol = .Cells.SpecialCells(xlCellTypeLastCell).Column
.Cells(1, lastcol + 1) = .Cells(1, lastcol) + 7
For Each c In Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
x = .Columns(1).Find(c).Row
.Cells(x, lastcol + 1).Value = Cells(c.Row, 2)
Next
End With
End Sub

 

[William Benson]

I did not get any error except that lastcol wasn't declared (so I remove
option explicit) and then it ran...

 

[EMoe]

I find one problem with this code. If you format the cells (e.g. with
currency or even with borders) the code skips those cells, and goes to
the next one. If you try to delete the formats, the code still
continues to the next cell.

Code:


Sub copytolastcol()
With Sheets("sheet2")
Range("a2:a10").Copy .Range("a2")
lastcol = .Cells.SpecialCells(xlCellTypeLastCell).Column
..Cells(1, lastcol + 1) = .Cells(1, lastcol) + 7
For Each c In Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
x = .Columns(1).Find(c).Row
..Cells(x, lastcol + 1).Value = Cells(c.Row, 2)
Next
End With
End Sub


How can you help?

Thanks,
ME

 

[Don Guillett]

This code does not skip formatting, it simply ignores it since you only
asked to copy the values. If you want the formatting you will need to use
copy/paste special

Sub copytolastcol()
Application.ScreenUpdating = False
With Sheets("sheet2")
Range("a2:a10").Copy .Range("a2")
lastcol = .Cells.SpecialCells(xlCellTypeLastCell).Column
..Cells(1, lastcol + 1) = .Cells(1, lastcol) + 7
For Each c In Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
x = .Columns(1).Find(c).Row
'=====
Cells(c.Row, 2).Copy
..Cells(x, lastcol + 1).PasteSpecial Paste:=xlPasteAll
'=====
'instead of
'.Cells(x, lastcol + 1).Value = Cells(c.Row, 2)
Next
End With
Application.ScreenUpdating = False
End Sub

 

[EMoe]

Excellent!!!

This code does exactly what I need.

Regards,
EMo

 

[Don Guillett]

glad to hep