PDA

View Full Version : Solved: Illusive Macro



gelpena
02-04-2012, 07:46 PM
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).

jproffer
02-04-2012, 08:16 PM
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
02-04-2012, 08:21 PM
Had no idea these two forums were interconnected. Sorry.

jproffer
02-05-2012, 03:13 AM
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
02-05-2012, 01:52 PM
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

gelpena
02-05-2012, 02:08 PM
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
02-05-2012, 03:39 PM
You could do something like this
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

gelpena
02-05-2012, 04:00 PM
You could do something like this
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

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
02-05-2012, 04:12 PM
Try this
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

gelpena
02-05-2012, 04:23 PM
Try this
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


I get "Runtime error 91"

mdmackillop
02-05-2012, 04:28 PM
With the sample you posted? On what line?

gelpena
02-05-2012, 04:32 PM
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
02-05-2012, 04:42 PM
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
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

gelpena
02-05-2012, 05:31 PM
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
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


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
02-06-2012, 05:34 AM
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
02-06-2012, 08:46 PM
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?"



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

gelpena
02-06-2012, 08:48 PM
[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
02-07-2012, 05:52 PM
You could do something like this
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

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
02-07-2012, 06:43 PM
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
02-08-2012, 02:12 PM
Don't be so mean with your sample data if you want a robust solution.

gelpena
02-08-2012, 03:41 PM
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:

mdmackillop
02-08-2012, 04:55 PM
Too few data to check if duplicate names are returned. What else might go wrong that needs to be handled?

gelpena
02-08-2012, 06:03 PM
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.

gelpena
02-08-2012, 07:12 PM
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
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


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.

mdmackillop
02-09-2012, 07:24 AM
Do you want to add to previous data on the target sheet or to clear this and show only new values.

gelpena
02-09-2012, 07:50 AM
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).

gelpena
02-11-2012, 10:10 AM
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/microsoft-excel-vba-programming/212051-stop-values-duplication.html