Dear Friends,
I am trying a macro for the following activities. The steps are provided below:
STEPS:
1.Copy the sheet header from Column A (from $AS1........till $A162 each at a time) of say sheet named "CONTENT AVG".
2.Move to another sheet (say to sheet named "Allcontent")
3.Find the header copied from sheet ""CONTENT AVG" from $A$1.
4.Move to the previous column (Offset 0,-1)
5.Select the entire column
6.Find the word "Average"
7.Move 2 cells down in the same column and one cell to the next row (First Offset(2, 0) and then Offset(0, 1))
8. Select the value (which is the average value of the whole column)
9. Copy the value
10. Move back (From "Allcontent" sheet) to the "CONTENT AVG" sheet
11.Paste the value to the next blank cell in B2 column (Column A contains the corresponding header name)
12. Loop through until the last header (Total header is 161 in number)
I have developed the code and for one search at a time it is working fine but once i am trying to put it in a loop (like the Do Until loop tried in the following code) it is not working and debugger is showing problem in the find option.
Please look into the code below and suggest me the alterations and rectifications or some other codes which can perform the task.
It is not possible to perform it one by one as I have to copy the header 161 times for a single sheet where I have more than 100 such sheets to extract.
Sub Macro4()
'
' Macro4 Macro
'
'
ActiveSheet.Select
Do
Range("A2").Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Sheets("Allcontent").Select
Cells.Find(What:="XYXYXYXYXYXYXYXY", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Select
ActiveCell.Offset(0, -1).Select
ActiveCell.EntireColumn.Select
Selection.Find(What:="Average", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Select
ActiveCell.Offset(2, 0).Select
ActiveCell.Offset(0, 1).Select
ActiveCell.Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
Sheets("CONTENT AVG").Select
Range("B2").Select
MaxRows = Cells(Rows.Count, "B").End(xlUp).Row
Range("B" & MaxRows + 1).Select
ActiveSheet.Paste
Loop Until Range("A162").Select = "ABCDEF"
End Sub
Looking eagerly for your kind help.
Thanks in advance.
Best Regards,
Amit
Bookmarks