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
Private LRow As Long
Private x As Long
Private y As Long
Private wbStart As Workbook
Private wsStart As Worksheet
Private varFilePaths As Variant
'------------------------------
Sub TRY()
Dim myCodeNum As String
Dim myFormula As String
Dim a() As String
Dim i As Long
Dim myWBPath As String
Dim myWBName As String
Dim intCount As Long
Set wsStart = ActiveSheet
Set wbStart = ActiveWorkbook
Call ClearZeros
End Sub
'----------------------------------------------
Sub [COLOR="blue"]ClearZeros[/COLOR]()
Dim a()
With wsStart
'//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
ReDim a(0 To intCount)
a(UBound(a)) = "C:\Work\OTT_Pricing\OTT_Repl_Update\" & myCodeNum & "_Repl.xls"
intCount = intCount + 1
Next x
varFilePaths = a
BubbleSort (varFilePaths)
FilterForUniques (varFilePaths)
For x = LBound(varFilePaths) To UBound(varFilePaths)
Workbooks.Open (varFilePaths(x))
With ActiveWorkbook.Worksheets(1)
[COLOR="blue"]'//CODE TO DELETE ROWS HERE!!![/COLOR]
End With
Next x
End With
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
'-------------------------------------------------------
Private Sub FilterForUniques(ByRef a As Variant)
Dim i As Integer
Dim j As Integer
Dim l As Integer
Dim b() As Variant 'Keep an eye on these data types
a = BubbleSort(a)
l = LBound(a)
i = l
ReDim Preserve b(l To i) 'Seed first value in temp array
b(l) = a(l)
For j = LBound(a) + 1 To UBound(a) 'Add unique values
If a(j) <> a(j - 1) Then
i = i + 1
ReDim Preserve b(l To i)
b(i) = a(j)
End If
Next j
a = b 'assign temp array to passed argument
End Sub
'----------------------------------------------------------------------
'From http://support.microsoft.com/kb/133135
Function BubbleSort(ByVal tempArray As Variant) As Variant
Dim Temp As Variant
Dim i As Integer
Dim NoExchanges As Integer
Dim x As Long
' Loop until no more "exchanges" are made.
Do
NoExchanges = True
' Loop through each element in the array.
For i = 1 To UBound(tempArray) - 1
' Substitution when element is greater than the element following int
If tempArray(i) > tempArray(i + 1) Then
NoExchanges = False
Temp = tempArray(i)
tempArray(i) = tempArray(i + 1)
tempArray(i + 1) = Temp
End If
Next i
Loop While Not (NoExchanges)
BubbleSort = tempArray
End Function
