Solved: Illusive Macro

Hello to all,
I 'm just a novice to VBA and have been trying to get a little program to work. I need your help!: pray2:

Can anyone write a macro for my program that with a button on Sheet2:

- searches area of Sheet1 B1:B500 thru AC1:AC500 for dates (12-Jan, etc). In Column A1:A500 there are 500 names.

- Sheet2 has 365 columns labeled with dates (1-Jan, 2-Jan, etc). The value that's copied to these columns will be the name (Ai) corresponding to the date.

Example: if Sheet1 (B3 = 28-Jan) then column 28-Jan in Sheet2 would be populated with A3 value (name).

If you're going to cross post, please post a link to your post on the other site so someone won't give an solution that you have already tried.

http://www.mrexcel.com/forum/showthread.php?t=610954

Had no idea these two forums were interconnected. Sorry.

They are not necessarily "interconnected", but they do have many of the same users. :)

It's nothing to be sorry about at all, it just keeps people from spending time coming up with a solution to a problem that may have already been solved.

It's certainly permitted, but it's appreciated if you post a link to your question on other forums., that's all :)

No worries.

[VBA]Option Explicit

Sub Test()
Dim r As Range, cel As Range, tgt As Range
Set r = Sheets(1).Range("B1:D500").SpecialCells(xlCellTypeConstants)
For Each cel In r
If IsDate(r) Then
Set tgt = Sheets(2).Columns(1).Find(cel)
Sheets(2).Cells(tgt.Row, Columns.Count).End(xlToLeft).Offset(, 1) = Sheets(1).Cells(cel.Row, 1)
End If
Next
End Sub
[/VBA]

MD,
Thanks for taking the time to help me with this.

[QUOTE][/
"Provide sample data and layout if you want a quicker solution." - MD
QUOTE]
I have included the file and how it would ideally be arranged once the button is pressed.

Thanks again.

You could do something like this
[VBA]Sub test()
Dim nameColumn As Range, nameAddress As String
Dim dataField As Range, fieldAddress As String
Dim resultHeaders As Range
Dim formulaRange As Range
Dim headerAddress As String
Dim formulaStr As String
With Sheet1.Columns(1)
Set nameColumn = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
Set dataField = nameColumn.Offset(0, 1).Resize(, 13)
Set resultHeaders = Sheet2.Range("d1:j1")

Set formulaRange = resultHeaders.Offset(1, 0).Resize(nameColumn.Rows.Count)

nameAddress = nameColumn.Cells(1, 1).Address(False, True, xlR1C1, True, formulaRange.Cells(1, 1))
fieldAddress = dataField.Rows(1).Address(False, True, xlR1C1, True, formulaRange.Cells(1, 1))

formulaStr = "REPT(" & nameAddress & ",ISNUMBER(MATCH(R1C," & fieldAddress & ",0)))"
With formulaRange
.FormulaR1C1 = "=" & formulaStr
.Value = .Value
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
On Error GoTo 0
End With
End Sub[/VBA]

Quote:

---

Originally Posted by mikerickson

You could do something like this
[vba]Sub test()
Dim nameColumn As Range, nameAddress As String
Dim dataField As Range, fieldAddress As String
Dim resultHeaders As Range
Dim formulaRange As Range
Dim headerAddress As String
Dim formulaStr As String
With Sheet1.Columns(1)
Set nameColumn = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
Set dataField = nameColumn.Offset(0, 1).Resize(, 13)
Set resultHeaders = Sheet2.Range("d1:j1")

Set formulaRange = resultHeaders.Offset(1, 0).Resize(nameColumn.Rows.Count)

nameAddress = nameColumn.Cells(1, 1).Address(False, True, xlR1C1, True, formulaRange.Cells(1, 1))
fieldAddress = dataField.Rows(1).Address(False, True, xlR1C1, True, formulaRange.Cells(1, 1))

formulaStr = "REPT(" & nameAddress & ",ISNUMBER(MATCH(R1C," & fieldAddress & ",0)))"
With formulaRange
.FormulaR1C1 = "=" & formulaStr
.Value = .Value
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
On Error GoTo 0
End With
End Sub[/vba]

---

Mike,
This is great! I don't know how to thank you!, but it only searchs the B column. How can it be modified to search all other columns all the way to AC?

Try this
[VBA]Option Explicit

Sub Test()
Dim r As Range, cel As Range, tgt As Range
Set r = Sheets(1).Range("B1:AC500").SpecialCells(xlCellTypeConstants)
For Each cel In r
If IsDate(cel) Then
Set tgt = Sheets(2).Rows(1).Find(cel)
Sheets(2).Cells(Rows.Count, tgt.Column).End(xlUp)(2) = Sheets(1).Cells(cel.Row, 1)
End If
Next
End Sub
[/VBA]

Quote:

---

Originally Posted by mdmackillop

Try this
[vba]Option Explicit

Sub Test()
Dim r As Range, cel As Range, tgt As Range
Set r = Sheets(1).Range("B1:AC500").SpecialCells(xlCellTypeConstants)
For Each cel In r
If IsDate(cel) Then
Set tgt = Sheets(2).Rows(1).Find(cel)
Sheets(2).Cells(Rows.Count, tgt.Column).End(xlUp)(2) = Sheets(1).Cells(cel.Row, 1)
End If
Next
End Sub
[/vba]

---

I get "Runtime error 91"

With the sample you posted? On what line?

Quote:

---

Originally Posted by mdmackillop

With the sample you posted? On what line?

---

This line. Let me make sure, this code was to replace the original one you provided, right?

Sheets(2).Cells(Rows.Count, tgt.Column).End(xlUp)(2) = Sheets(1).Cells(cel.Row, 1)

That error will occur if there is no date in Sheet 2 to match that in found on Sheet 1

This has error handling added
[VBA]Sub Test()
Dim r As Range, cel As Range, tgt As Range
Set r = Sheets(1).Range("B1:AC500").SpecialCells(xlCellTypeConstants)
On Error Resume Next
For Each cel In r
If IsDate(cel) Then
Set tgt = Sheets(2).Rows(1).Find(cel)
Sheets(2).Cells(Rows.Count, tgt.Column).End(xlUp)(2) = Sheets(1).Cells(cel.Row, 1)
If Err <> 0 Then
MsgBox "Date " & cel & " not found"
Err.Clear
End If
End If
Next
End Sub
[/VBA]

Quote:

---

Originally Posted by mdmackillop

That error will occur if there is no date in Sheet 2 to match that in found on Sheet 1

This has error handling added
[vba]Sub Test()
Dim r As Range, cel As Range, tgt As Range
Set r = Sheets(1).Range("B1:AC500").SpecialCells(xlCellTypeConstants)
On Error Resume Next
For Each cel In r
If IsDate(cel) Then
Set tgt = Sheets(2).Rows(1).Find(cel)
Sheets(2).Cells(Rows.Count, tgt.Column).End(xlUp)(2) = Sheets(1).Cells(cel.Row, 1)
If Err <> 0 Then
MsgBox "Date " & cel & " not found"
Err.Clear
End If
End If
Next
End Sub
[/vba]

---

It's getting there! thanks so much for your time. Now, if I keep pressing the button, the names are duplicated in the same column. This is not ideal if my user keeps pressing the button...

Add a line to clear the cell contents after they are copied, or clear the target cells. I don't know how you will use this.

Quote:

---

Originally Posted by mdmackillop

Add a line to clear the cell contents after they are copied, or clear the target cells. I don't know how you will use this.

---

MD,

Thanks for all your support. The code below has worked better so far. Could you get this code to collect data in the same manner but from a "Sheet3?"

[VBA]

Sub test() Dim nameColumn As Range, nameAddress As String Dim dataField As Range, fieldAddress As String Dim resultHeaders As Range Dim formulaRange As Range Dim headerAddress As String Dim formulaStr As String With Sheet1.Columns(1) Set nameColumn = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)) End With Set dataField = nameColumn.Offset(0, 1).Resize(, 13) Set resultHeaders = Sheet2.Range("d1:j1") Set formulaRange = resultHeaders.Offset(1, 0).Resize(nameColumn.Rows.Count) nameAddress = nameColumn.Cells(1, 1).Address(False, True, xlR1C1, True, formulaRange.Cells(1, 1)) fieldAddress = dataField.Rows(1).Address(False, True, xlR1C1, True, formulaRange.Cells(1, 1)) formulaStr = "REPT(" & nameAddress & ",ISNUMBER(MATCH(R1C," & fieldAddress & ",0)))" With formulaRange .FormulaR1C1 = "=" & formulaStr .Value = .Value On Error Resume Next .SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp On Error Goto 0 End With End Sub

[/VBA]

[quote=gelpena]MD,

Thanks for all your support. The code below has worked better so far. Could you get this code to collect data in the same manner but from a "Sheet3?"

I'm an idiot! sorry...It's the longer code you wrote.

Quote:

---

Originally Posted by mikerickson

You could do something like this
[vba]Sub test()
Dim nameColumn As Range, nameAddress As String
Dim dataField As Range, fieldAddress As String
Dim resultHeaders As Range
Dim formulaRange As Range
Dim headerAddress As String
Dim formulaStr As String
With Sheet1.Columns(1)
Set nameColumn = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
Set dataField = nameColumn.Offset(0, 1).Resize(, 13)
Set resultHeaders = Sheet2.Range("d1:j1")

Set formulaRange = resultHeaders.Offset(1, 0).Resize(nameColumn.Rows.Count)

nameAddress = nameColumn.Cells(1, 1).Address(False, True, xlR1C1, True, formulaRange.Cells(1, 1))
fieldAddress = dataField.Rows(1).Address(False, True, xlR1C1, True, formulaRange.Cells(1, 1))

formulaStr = "REPT(" & nameAddress & ",ISNUMBER(MATCH(R1C," & fieldAddress & ",0)))"
With formulaRange
.FormulaR1C1 = "=" & formulaStr
.Value = .Value
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
On Error GoTo 0
End With
End Sub[/vba]

---

I tried this and it worked! Thank you so much for your hard work! How can this code be modified to search not only Sheet2 but also Sheet3? I tried duplicating the code, changing the parameters and calling both macros from a sub. But the last one overrides the first.

Quote:

---

Originally Posted by gelpena

I tried this and it worked! Thank you so much for your hard work! How can this code be modified to search not only Sheet2 but also Sheet3? I tried duplicating the code, changing the parameters and calling both macros from a sub. But the last one overrides the first.

---

here's a copy of the file.

Don't be so mean with your sample data if you want a robust solution.

Quote:

---

Originally Posted by mdmackillop

Don't be so mean with your sample data if you want a robust solution.

---

The least I want to be is mean to you guys who have helped me so much!. How was I mean with my sample data? :friends:

Too few data to check if duplicate names are returned. What else might go wrong that needs to be handled?

Quote:

---

Originally Posted by mdmackillop

Too few data to check if duplicate names are returned. What else might go wrong that needs to be handled?

---

You're right. I just thought It would be redundant. There's nothing else I can think of. Cosmetic details are not that important.

Quote:

---

Originally Posted by mdmackillop

That error will occur if there is no date in Sheet 2 to match that in found on Sheet 1

This has error handling added
[vba]Sub Test()
Dim r As Range, cel As Range, tgt As Range
Set r = Sheets(1).Range("B1:AC500").SpecialCells(xlCellTypeConstants)
On Error Resume Next
For Each cel In r
If IsDate(cel) Then
Set tgt = Sheets(2).Rows(1).Find(cel)
Sheets(2).Cells(Rows.Count, tgt.Column).End(xlUp)(2) = Sheets(1).Cells(cel.Row, 1)
If Err <> 0 Then
MsgBox "Date " & cel & " not found"
Err.Clear
End If
End If
Next
End Sub
[/vba]

---

Ok MD,
I duplicated your code(above) and changed the source sheet. called both macros from an outside sub and It's doing what I'm looking for it to do. Last thing I need help with is the duplication of the values. I want it to copy new updated data, not duplicate the existing one again. As it is right now, if I pressed the button ten times, it would copy the same data 10 times. See attached file.

Do you want to add to previous data on the target sheet or to clear this and show only new values.

Quote:

---

Originally Posted by mdmackillop

Do you want to add to previous data on the target sheet or to clear this and show only new values.

---

The target sheet(Sheet2) should retain old data(unless deleted from source sheets(Sheet1,Sheet3). If no new values are added to source sheets then when button is pressed then nothing should happen. If new data is added to source sheets then target sheet should add the new data to the existing one. (If Ray is scheduled to work on Jan 20 (already in tgt sheet) and now John has been added to the schedule, then the macro would know Ray is already there and only John should be added. As it is now, it adds Ray again and then John).

Thank you to all who looked at my code and provided assistance. Thank you mdmackillop very, very much for the code! Nsenor Udofa provided me with the last line. Thanks all!!!!:beerchug:


http://www.thecodecage.com/forumz/mi...plication.html