VBA to find Correct Column and Copy/Paste Values

[moony]

Hello,

I am working on a sheet called Monthly that automatically pulls the relevant data from the ABR Drop In sheet. The cells confirm the month referenced above in cell H5 matches the date inputted in the ABR Drop In sheet in cell H5. The Monthly sheet has the dates listed in Monthly!$F$5:$EH$5. Only the blue cells are inputs, and the goal is to have a button on the ABR Drop In sheet that will look at the date in cell 'ABR Drop In'!H5, find that column in the Monthly sheet, and copy/paste all the blue input cells as values.

Appreciate any help I can get!

Thanks!

Hotel AM Tracker v1 - test.xlsx
	B	C	D	E	F	G	H
5	Input Month Ending Date of Statements Below:						12/31/2021
ABR Drop In

Hotel AM Tracker v1 - test.xlsx
	H
5	Dec 2021
6	2
7	1
8
9	49
10
11
12
13	1,519
14	458
15	351
16	107
17	30.2%
18	990.66
19	1,240.21
20	396.58
21	298.70
22
23	--
24	--
25
26
27	--
28	--
29
30
31	--
32
33	--
34	--
35
36
37	--
38	--
39
40
41	--
42
43	1,519
44	458
45	351
46	107
47	30.2%
48	990.66
49
50
51	298.70
52
53
54	453,721
55
56
57	215,575
58	116,669
59	8,941
60	25,887
61	971
62	63,107
63	103,983
64	99,743
65	2,153
66	1,800
67	287
68
69	15,602
70	12,600
71
72	46,337
73	1
74	--
75	36,316
76	424
77	9,596
78
79	847,818
80
81
82	242,656
83
84
85	422,221
86	28,207
87
88
89	81,249
90	--
91	--
92	73,960
93	7,289
94	0
95
96	774,333
97
98	73,485
99
100
101	196,141
102	44,272
103	166,620
104	66,466
105	28,330
106
107	501,830
108
109	(428,345)
110
111	21,195
112
113
114	(449,540)
115
116
117	(78,884)
118	12,617
119	5,070
120
121
122
123
124	(61,197)
125
126	(388,343)
127
128	16,927
129
130	(405,270)
Monthly

 

[moony]

​

So link your workbook on a files host website like Dropbox …​

Dropbox download link to excel test file

 

[Marc L]

For some reason your workbook is not readable under my Excel version but someone else may help you …​

 

[moony]

Can anyone else help with the below? I'm not able to set the rng correctly as it returns Nothing.

Sub PasteMonthlyPL()
 
 Application.ScreenUpdating = False
 Dim wb As Workbook
 Dim s1 As Worksheet
 Dim s2 As Worksheet
 Dim rng As Range
 Dim MonthlyPL As Date
 Dim colnumber As Long
 
 Set wb = ThisWorkbook
 Set s1 = wb.Worksheets("ABR Drop In")
 Set s2 = wb.Worksheets("Monthly")
 
 MonthlyPL = s1.Cells(5, 8)
 
 With s2
    Set rng = .Rows(5).Find(What:=MonthlyPL, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
 End With
 
 If rng Is Nothing Then
    MsgBox "Date Not Found"
 Else
    colnumber = rng.Column
    
    s2.Cells(9, colnumber).Copy
    s2.Cells(9, colnumber).PasteSpecial Paste:=xlPasteValues
 
 End If
  

Application.ScreenUpdating = True
End Sub

 

[moony]

made more changes and i think i got it to work. any chance it could be more efficient?

Sub PasteMonthlyPL()
 
 Application.ScreenUpdating = False
 Dim wb As Workbook
 Dim s1 As Worksheet
 Dim s2 As Worksheet
 Dim rng As Range
 Dim MonthlyPL As Double
 Dim colnumber As Long
 Dim LastRow As Integer
 Dim LastColumn As Integer
 Dim LastCell
 
 Set wb = ThisWorkbook
 Set s1 = wb.Worksheets("ABR Drop In")
 Set s2 = wb.Worksheets("Monthly")
 Set LastCell = s2.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious)
 LastRow = LastCell.Row
 LastColumn = LastCell.Column
 
 MonthlyPL = s1.Cells(5, 8).Value

 For Each cell In s2.Range("F5", Cells(5, LastColumn)).Cells
    If cell = MonthlyPL Then
        colnumber = cell.Column
        Exit For
    End If
 Next
 
 If colnumber = 0 Then
    MsgBox "Date Not Found"
 Else
    
    For Each cell In s2.Range(Cells(1, colnumber), Cells(LastRow, colnumber)).Cells
        If cell.HasFormula = True And cell.Font.Color = RGB(0, 0, 255) Then
            cell.Value = cell.Value
        End If
    Next
    
 End If

Application.ScreenUpdating = True
End Sub

 

[Marc L]

any chance it could be more efficient?

Yes obviously removing the useless and using elements of my previous demonstration !​

​

According to the Macro Recorder just with a filter Excel basics my VBA demonstration revamped :​

Sub Demo1r()
     Dim V
    With Sheets("Monthly").UsedRange.Columns
         V = Application.Match(['ABR Drop In'!H5], .Rows(5 - .Row + 1), 0):  If IsError(V) Then Beep: Exit Sub
        .Item(V).AutoFilter 1, 16711680, 9
         If Application.Subtotal(103, .Item(V)) > 1 Then With .Item(V).Offset(1).SpecialCells(12): .Formula = .Value2: End With
        .AutoFilter
    End With
End Sub