Code:
Sub MakeFormulas4() ' http://www.excelfox.com/forum/showthread.php/2390-Apply-Vlookup-formula-in-all-the-available-sheets-in-a-workbook?p=11827&viewfull=1#post11827
Rem 1 ' Workbooks info
' 1a This months book, this workbook. It is the outout book for the current month
Dim ThisMonthsLatestBook As Workbook, LisWbName As String
Set ThisMonthsLatestBook = ThisWorkbook ' ActiveWorkbook
Let LisWbName = ThisMonthsLatestBook.Name
' If InStr(7, LisWbName, Format(Now(), "MMM"), vbTextCompare) = 0 Then MsgBox Prompt:="This workbook is not for " & Format(Now(), "MMMM"): Exit Sub
'Dim BookN As Long
' Let BookN = Mid(LisWbName, 5, InStr(5, LisWbName, "_", vbBinaryCompare) - 5)
' 1b Last months book
Dim strDteLisBk As String, DteLisBk As Date
Let strDteLisBk = Mid(LisWbName, 32, 8)
Dim LooksLikeADate As String: Let LooksLikeADate = Right(strDteLisBk, 2) & "." & Mid(strDteLisBk, 5, 2) & "." & Left(strDteLisBk, 4)
Let DteLisBk = CDate(LooksLikeADate) ' 31.12.2019 Looks like a date
Dim sourceBookName As String
' Let sourceBookName = "Book" & BookN - 1 & "_" & Format(DateAdd("m", -1, Now()), "MMM YYYY") & ".xlsm"
Let sourceBookName = "MSCI Equity Index Constituents " & Format(DateAdd("m", -1, DteLisBk), "YYYYMMDD") & ".xlsm"
Dim sourceBook As Workbook
Set sourceBook = Workbooks.Open(ThisWorkbook.Path & "\" & sourceBookName)
Rem 2 Make records worksheet Sub MakeWorkSheetIfNotThere()
'Dim Wb As Workbook ' ' ' Dim: ' Preparing a "Pointer" to an Initial "Blue Print" in Memory of the Object ( Pigeon Hole with a bit of paper or code lines on that can be filled in to refer to a specific Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense ) '
' Set Wb = ActiveWorkbook ' ' Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 '
If Not Evaluate("=ISREF(" & "'" & "Records" & "'!Z78)") Then ' ( the ' are not important here, but in general allow for a space in the worksheet name like "My Records"
ThisMonthsLatestBook.Worksheets.Add After:=ThisMonthsLatestBook.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
Dim wsRcds As Worksheet '
Set wsRcds = ThisMonthsLatestBook.Worksheets.Item(ThisMonthsLatestBook.Worksheets.Count) 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 ' Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191
wsRcds.Activate: wsRcds.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
Let wsRcds.Name = "Records"
Else ' The worksheet is already there , so I just need to set my variable to point to it
Set wsRcds = ThisWorkbook.Worksheets("Records")
End If
' End Sub
Rem 3 looping through worksheets
Dim C As Long, I As Long
'C = ActiveWorkbook.Worksheets.Count
'Let C = ThisWorkbook.Worksheets.Count
Let C = ThisMonthsLatestBook.Worksheets.Count - 1 ' -1 since last worksheet is records worksheet
'For I = 1 To C
'Application.ScreenUpdating = True
For I = 1 To C ' Sheet1 , Sheet2 , Sheet3 .......
'what are our worksheets? I = 1 , 2 , 3 ..........
Dim sourceSheet As Worksheet
Set sourceSheet = sourceBook.Worksheets.Item(I) ' ("Sheet1") , Sheet2 , Sheet3 ........
Dim outputSheet As Worksheet
Set outputSheet = ThisWorkbook.Worksheets.Item(I) ' ("Sheet1") , Sheet2 , Sheet3 ........
'Determine last row of source
With sourceSheet
Dim SourceLastRow As Long
SourceLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With outputSheet
'Determine last row in col P
Dim OutputLastRow As Long
OutputLastRow = .Cells(.Rows.Count, "P").End(xlUp).Row
End With
'Apply our formula in records worksheet
With Worksheets("Records")
Let .Cells.Item(1, I).Value = sourceSheet.Name ' Header in column as worksheet name
'.Range("Q2:Q" & OutputLastRow).Formula = "=VLOOKUP($A2,'[" & sourceBook.Name & "]" & sourceSheet.Name & "'!$A$2:$P$" & SourceLastRow & ",3,0)"
.Range("" & CL(I) & "2:" & CL(I) & "" & OutputLastRow).Value = "=VLOOKUP(" & outputSheet.Name & "!$A2,'" & sourceBook.Path & "\" & "[" & sourceBook.Name & "]" & sourceSheet.Name & "'!$A$2:$P$" & SourceLastRow & ",3,0)"
' .Range("" & CL(I) & "2:" & CL(I) & "" & OutputLastRow).Value = .Range("" & CL(I) & "2:" & CL(I) & "" & OutputLastRow).Value
End With
'MsgBox ActiveWorkbook.Worksheets(I).Name
MsgBox ActiveWorkbook.Worksheets.Item(I).Name
Next I
'Next P
Rem 4
Dim cel As Range
With Worksheets("Records").UsedRange
For Each cel In .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
If IsError(cel.Value) Then
'
Else
If cel.Value < 3 Then
cel.Font.Color = vbRed
Else
cel.Font.Color = vbGreen
End If
End If
Next cel
End With
'Close the source workbook, don't save any changes
sourceBook.Close False
' Application.ScreenUpdating = True
End Sub
Reply With Quote
Bookmarks