Solved: Illusive Macro

[gelpena]

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!

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

[jproffer]

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

[gelpena]

Had no idea these two forums were interconnected. Sorry.

[jproffer]

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.

[mdmackillop]

[VBA]Option Explicit

Sub Test()
Dim r As Range, cel As Range, tgt As Range
Set r = Sheets(1).Range("B1500").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]

[gelpena]

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.

[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]

[gelpena]

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?

[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]

[gelpena]

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"

[mdmackillop]

With the sample you posted? On what line?

[gelpena]

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)

[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]

[gelpena]

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

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

[gelpena]

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]

[gelpena]

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

[gelpena]

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.

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

[mdmackillop]

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