Sub TRY()
Dim myCodeNum As String
Dim myFormula As String
Dim ws As Worksheet
Dim LRow As Long, x As Long, y As Long
Dim a() As String
Dim i As Long
Dim myWBPath As String
Dim myWBName As String
Dim wb As Workbook
[COLOR="Blue"]Dim wbStart As Workbook[/COLOR]
Dim intCount As Long
Const ROW_WHERE_FORMULA_STARTS As Long = 2 '//First formula will be in this row
Const COLUMN_TO_PUT_FORMULA_IN As Long = 7 '//Column Number to write formulas in..."A" = 1, "B" = 2 etc.
Const COLUMN_TO_DETERMINE_LAST_ROW_BY As Long = 3 '//Excel will fill formulas down as far as last cell in this column
Const COLUMN_WITH_CODE_NUMBERS As Long = 1 '//Column with number to determine Repl sheet number
'--------------------------------------------
Set ws = ActiveSheet
[COLOR="blue"]Set wbStart = ActiveWorkbook[/COLOR]
Application.DisplayAlerts = False
With ws
'//FIRST PASS-----------------------------------------------------------
LRow = .Cells(Rows.Count, COLUMN_TO_DETERMINE_LAST_ROW_BY).End(xlUp).Row
y = COLUMN_TO_PUT_FORMULA_IN
For x = ROW_WHERE_FORMULA_STARTS To LRow
'//Get sheet number to use in formula
myCodeNum = .Cells(x, COLUMN_WITH_CODE_NUMBERS).Value
'//Get workbook Name to use in Formula
myWBPath = "C:\Work\OTT_Pricing\OTT_Repl_Update\" & myCodeNum & "_Repl.xls"
myWBName = FileNameOnly(myWBPath)
'//Open workbook, capture its name (to close it later)
If IsWorkbookOpen(myWBName) Then
Set wb = Workbooks(myWBName)
Else
Workbooks.Open Filename:=myWBPath, ReadOnly:=True
Set wb = ActiveWorkbook
[COLOR="blue"]wbStart.Activate[/COLOR]
End If
myWBName = wb.Name
ReDim Preserve a(0 To intCount)
a(UBound(a)) = myWBName
intCount = intCount + 1
'//Create a formula string
myFormula = "=INDEX([" & myWBName & "]Sheet1'!R1C5:R5000C5,MATCH(1,IF([" & myWBName & "]Sheet1'!R1C1:R5000C1=RC3,IF([" & myWBName & "]Sheet1'!R1C5:R5000C5<>0,1)),0))"
'//write formula to cell
.Cells(x, y).FormulaArray = myFormula
Next x
'//SECOND PASS - hard copy values----------------------------------------
For x = ROW_WHERE_FORMULA_STARTS To LRow
.Cells(x, y).Value = .Cells(x, y).Value
If IsError(.Cells(x, y).Value) Then
.Cells(x, y).ClearContents
End If
Next x
'//THIRD PASS - do something with blank cells----------------------------
For x = ROW_WHERE_FORMULA_STARTS To LRow
If Len(.Cells(x, y).Value) = 0 Then
'//Do Something with blank cell
'//Do Something with blank cell
myCodeNum = .Cells(x, COLUMN_WITH_CODE_NUMBERS).Value
myFormula = "=INDEX([" & myWBName & "]Sheet1!R2C3:R5000C19,MIN(IF([" & myWBName & "]Sheet1!R2C1:R5000C1=RC3,IF([" & myWBName & "]Sheet1!R2C3:R5000C19>0,ROW([" & myWBName & "]Sheet1!R2C3:R5000C19)-ROW([" & myWBName & "]Sheet1!R2C3)+1))),MATCH(TRUE,INDEX([" & myWBName & "]Sheet1!R2C3:R5000C19,MIN(IF([" & myWBName & "]Sheet1!R2C1:R5000C1=RC3,IF([" & myWBName & "]Sheet1R2C3:R5000C19>0,ROW([" & myWBName & "]Sheet1!R2C3:R5000C19)-ROW([" & myWBName & "]Sheet1!R2C3)+1))),0)>0,0))"
.Cells(x, y).FormulaArray = myFormula
End If
Next x
'//close workbooks we opened
For i = LBound(a) To UBound(a)
Workbooks(a(i)).Close SaveChanges:=False
Next i
End With
Application.DisplayAlerts = True
End Sub
'--------------------------------------------------
Function IsWorkbookOpen(strWorkbookName) As Boolean
Dim strTemp As String
On Error Resume Next
strTemp = Workbooks(strTemp).Name
If Err Then
IsWorkbookOpen = False
Else
IsWorkbookOpen = True
End If
End Function
'----------------------------------------------
Function FileNameOnly(Arg1 As String) As String
FileNameOnly = _
StrReverse(Left(StrReverse(Arg1), InStr(1, StrReverse(Arg1), "\") - 1))
End Function
