Copy and Paste Macro Based on Matching Values Not Doing Anything

[matt767]

I have 2 sheets, Sheet1 and Summary. In Sheet1, the first row contains text that may or may not be contained in column C of Summary. I am trying to copy and paste the values in Summary's column D alongside column C matches to Sheet1's first row (the data in Summary is already grouped by column C) into row 7 beneath the corresponding match in Sheet1. I have succeeded in doing it individually with the following code

Sub allowed()
Dim cel As Range
Dim cel2 As Range
Dim srchrng1 As Range
Dim srchrng2 As Range
Set srchrng1 = Sheets("Sheet1").Range("a1:ac1")
Set srchrng2 = Sheets("Summary").Range("c1:c80000")
For Each cel In srchrng1
For Each cel2 In srchrng2
If cel.Value = cel2.Value Then
Dim list As Range
Set list = Range(cel.Offset(0, 0), cel.Offset(1000, 0))
Dim x As Long
x = Application.WorksheetFunction.CountA(list)
cel2.Offset(0, 1).Copy
cel.Offset(x, 0).PasteSpecial
End If
Next cel2
Next cel
End Sub

but it takes roughly 30 seconds to execute and I am trying to do it faster via 2 other methods which have not returned errors but nonetheless do nothing leaving Sheet1 blank (see below).

Sub allowed2()
Dim cel As Range
Dim srchrng1 As Range
Set srchrng1 = Sheets("Sheet1").Range("a1:ac1")
For Each cel In srchrng1
Dim StartRow As Long, EndRow As Long
Sheets("Summary").Activate
If InStr("C:C", cel.Text) > 0 Then
StartRow = Application.WorksheetFunction.Match(cel.Text, "C:C", 0)
EndRow = Application.WorksheetFunction.Match(cel.Text, "C:C", 0) + Application.WorksheetFunction.CountIf(Columns("C"), cel.Text) - 1
Sheets("Summary").Range(Cells(StartRow, 4), Cells(EndRow, 4)).Copy
Sheets("Sheet1").cel.Offset(6, 0).PasteSpecial
Else
cel.Offset(6, 0).Value = ""
End If
Next cel
End Sub

Sub allowed3()
Dim cel As Range
Dim srchrng1 As Range
Set srchrng1 = Sheets("Sheet1").Range("a1:ac1")
Dim res As Variant
Dim res2 As Variant
For Each cel In srchrng1
Sheets("Summary").Activate
res = Application.Match(cel.Text, "C:C", 0)
res2 = Application.CountIf(Columns("C"), cel.Text)
If IsError(res) Then
cel.Offset(6, 0).Value = ""
Else
Sheets("Summary").Range(Cells(res, 4), Cells(res + res2 - 1, 4)).Copy
Sheets("Sheet1").cel.Offset(6, 0).PasteSpecial
End If
Next cel
End Sub

Please let me know why these 2 other macros run but do nothing. Thank you so much.

 

[matt767]

anyone?

 

[matt767]

solved:

Sub allowed2()
Dim cel As Range
Dim srchrng1 As Range
Set srchrng1 = Sheets("Sheet1").Range("a1:ac1")
Dim rng As Range
Set rng = Sheets("Summary").Range("C:C")
For Each cel In srchrng1
Dim StartRow As Long
Dim EndRow As Long
Sheets("Summary").Activate
If Application.WorksheetFunction.CountIf(rng, cel.Text) > 0 Then
StartRow = Application.WorksheetFunction.Match(cel.Text, rng, 0)
EndRow = Application.WorksheetFunction.Match(cel.Text, rng, 0) + Application.WorksheetFunction.CountIf(Columns("C"), cel.Text) - 1
Sheets("Summary").Range(Cells(StartRow, 4), Cells(EndRow, 4)).Copy
cel.Offset(6, 0).PasteSpecial
Else
cel.Offset(6, 0).Value = ""
End If
Next cel
End Sub

this is much faster than my first method.