Copy to cells based on Row/Column labels in another workbook

[Guest]

I receive about 50 spreadsheets each week by email. I open the attachment,
verify the data and want to run a macro that will copy just one cell of data
from the worksheet and put the value ($) into a seperate (always the same
name) workbook that has column headings (Row A) of the date of the end of
each week. Column A has the number of the office sending the data. Each
worksheet I receive has both the week ending date (which corresponds to the
date in Row A) and the office number (which corresponds to the office number
in Column A). The cell containing the data is always constant.
Example, the file I receive and open is from Office 10, (cell A1=10), and
dated 05/29/05 (cell A2=05/29/05). The total sales is $3,000 (cell A3=3000).
I want to post the info in cell A3, to workbook named summary.xls and place
it in the correct cell for the matching week and office number. In the
summary.xls workbook, let's say that week 05/29/05 is in cell F1, and Office
10 is in cell A11. The target cell would be the intersection of F1 and A11 or
F11. How do I write a macro that reads the date, office variables in the
original workbook, then validates both variables in the new workbook, and
them determines the row and column and resolves to an individual cell to
write $3,000 to F11? This would be a great help!

 

[Nigel]

Hi David, here is one approach, place the following in a summary.xls code
module. To use it, Open the summary workbook then open your data source
(emailed attachement) with this active, choose run->macros
summary.xls!transfer and the value gets transferred into the summary book
in the matching location. If the office number and/or date is not set up in
the summary sheet then you get an error message. Alternatively you might
want to use this to create a new office or date in the summary book.

Sub Transfer()
Dim wbSum As Workbook, wbData As Workbook
Set wbSum = Workbooks("Summary.xls")
Set wbData = ActiveWorkbook

' get source data from open sheet
Dim iOffice As Integer, iDate As Date, iValue
With wbData.Sheets("Sheet1")
iOffice = .Range("A1")
iDate = .Range("A2")
iValue = .Range("A3")
End With
' apply values to matched row and column
With wbSum.Sheets("Sheet1")
Dim lastrow As Long, lastcol As Long, xV As Long, xR As Long, xC As Long
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
'get matching row
For xV = 1 To lastrow
If iOffice = .Cells(xV, 1) Then xR = xV
Next xV
If xR = 0 Then MsgBox "Office: " & iOffice & " not found in summary
table"

' get matching column
For xV = 1 To lastcol
If iDate = .Cells(1, xV) Then xC = xV
Next xV
If xC = 0 Then MsgBox "Date: " & iDate & " not found in summary table"
If xR > 0 And xC > 0 Then .Cells(xR, xC) = iValue
End With

End Sub

 

[EMoe]

Hello,

I tried this code myself, and it works. This is alot of code for jus
one cell.

How do you add to this one to include other cells values? Maybe yo
want to to transfer 10 or 20 pieces of data.

Thanks,
EMo

 

[Guest]

Hi Nigel,
I can't tell you how much I appreciate this....
When I copied and pasted the code, for some reason the "Table" in not found
in summary table got truncated, but I found that and the code ran great. But
I did get a message box that said, "Date: 12/31/1899 not found in summary
table.
I have two files open: summary.xls with dates in row 1 starting with column
b, starting with 05/08/2005. C1 is 05/15/05 and continues on every seven
days. Starting with Column A, row 2, I have location numbers, 1,2,3, etc. to
number 50.
I recorded a new macro to get one started, selected a cell, ended the
record, then edited the macro and pasted all your code (and fixed the one
problem). I did this in the summary.xls workbook.
I have another workbook open BFP-SARASOTA-FL-05-29-05.xls with 10 in A1,
5/29/2005 in A2, and 3000 in A3. I ran the macro from the summary sheet and
received the Msg Box with the date not found error.
What did I do wrong? How is the code finding the source file?
Thanks again!!

 

[Guest]

Never mind...you're a GENIUS. I ran the code from the open source file and it
worked perfect!
Thanks again!!!!!

 

[Guest]

I suspect that you just add more data variables.....but I'll let the GENIUS
give you the "absolute" answer.
Nigel, I'd love to give you credit in the Macro...anything you want me to
put up top for you?

David...and THANKS AGAIN!

 

[Nigel]

Glad you like it. You have to run it from the open source file - which must
be active. I did it this way as when you click on the email attachment this
becomes the open and active file. Running the macro should be OK - (have
the summnary.xls open already). I could provide a trap to prevent it
running from elsewhere if you like?

You could do a lot more to prevent errors, validate dates etc. It strucmk
me that the date provided in each office submission might not comply with
the format rules - so an error trap here migth be good thing?

Also you need to add new offices and dates manually - this could be
automated.

 

[Guest]

You've done so much already....I'm hating to even ask, but you are quite
correct, if you could add a trap to validate the date (and the format), maybe
a message box to override the date from the source file and another trap that
would create the new location number, should it not exist, with a msg box
confirming this action before it's taken. Those are great ideas, and again, I
cannot tell you how much I appreciate it!
And yes...it worked just perfectly as I had asked it too...directly from the
source file itself...that was definately my bad!!

David

 

[Guest]

Nigel,
If it's not too much trouble, currently, the spreadsheets that come in do
NOT have a location number, although the summary sheet does. I am developing
an update to the spreadsheet that will have the location number in the
future. They do contain the date.
However, until then, could we put a user interface in that would ask the
operator for the location number if the field that will hold the location
number contains no data?

Thanks much again!!

David

 

[Nigel]

Hi David
Here is a version that includes the following.
1. Checks the data in cell A2 is valid - if not ends program
2. Checks there is an office number - if not asks user to enter number
3. Checks if the office number is in summary table - if not asks user if
they wish to add (adds after last row)
4. Allows dates to be in the range 1st to last day of month-year
5. If date out of range tell user and end program.

Hope this helps as a template, you might wish to tidy it up to suit your
needs.
'##########################################################
Sub Transfer()
Dim wbSum As Workbook, wbData As Workbook
Set wbSum = Workbooks("Summary.xls")
Set wbData = ActiveWorkbook

' get source data from open sheet
Dim iOffice As Integer, iDate As Date, iValue
With wbData.Sheets("Sheet1")
iOffice = .Range("A1")
If IsDate(.Range("A2")) Then
iDate = .Range("A2")
Else
MsgBox "Date: " & .Range("A2") & " is not valid format", vbCritical
+ vbOKOnly, "Date Error"
Exit Sub
End If
iValue = .Range("A3")
End With
' apply values to matched row and column
With wbSum.Sheets("Sheet1")
Dim lastrow As Long, lastcol As Long, xV As Long, xR As Long, xC As Long
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
'get matching row
For xV = 2 To lastrow
If iOffice = .Cells(xV, 1) Then xR = xV
Next xV
If xR = 0 Then
' check if there is an office number
If iOffice < 1 Then
iOffice = Application.InputBox(prompt:="Enter Office Number",
Title:="No Office Number Found")
End If
If MsgBox("Office: " & iOffice & " not found in summary table" &
vbCrLf & _
"Do you want to add it to the summary table ?", vbExclamation +
vbYesNo) = vbYes Then
.Cells(lastrow + 1, 1) = iOffice
xR = lastrow + 1
End If
End If
' get matching column and date in range of month and year
For xV = 2 To lastcol
If Month(iDate) = Month(.Cells(1, xV)) And _
Year(iDate) = Year(.Cells(1, xV)) Then xC = xV
Next xV
If xC = 0 Then MsgBox "Date: " & iDate & " not found in summary table"
If xR > 0 And xC > 0 Then .Cells(xR, xC) = iValue

End With

End Sub
'###########################################################################
#