Sure, see below. My original query didn't have code or get a response so I
resubmitted with below.. Thanks for your help, God bless
Option Explicit
Dim exc As EXCEl.Application
Private Sub cmdChange_Click()
strFolder = txtPath.Text
Len(txtPath.Text) - 3)
' get th search path
strPath = strFolder & "\" & "*.xls"
' get the first file with workbook extension
strFile = Dir(strPath, vbNormal)
Do While Len(strFile) <> 0
'booReadOnly = False
If UCase(Left(strFile, 13)) = "EQUIPMENT VOL" Then
If GetAttr(strFolder & "\" & strFile) = vbReadOnly Then
' booReadOnly = True
SetAttr (strFolder & "\" & strFile), vbNormal
End If
'09/20/07 code below original code that worked-commented out to check
for err & added code below it
Set excBk = GetObject(strFolder & "\" & strFile, "Excel.Sheet")
For ndx = 1 To excBk.Worksheets.Count
excBk.Worksheets(ndx).Unprotect
FixLabels ndx '10/27/01
excBk.Worksheets(ndx).Protect
Next ndx 'ndx = 1 To excBk.Application.ActiveWorkbook.Worksheets.Count
excBk.Close savechanges:=True
Set excBk = Nothing '09/27/07
' check for next file
End If
strFile = Dir
Loop
End Sub
Module 1
Option Explicit
Public excBk as EXCEl.Workbook
Public Sub FixLabels(ndx As Integer)
Dim booNegative As Boolean
Dim dblCost As Double
Dim strVal As String
Dim row As Integer
Dim cell As Range
booNegative = False
excBk.Worksheets(ndx).Select
excBk.Worksheets(ndx).Activate
With excBk.Worksheets(ndx).Range("D10")
..HorizontalAlignment = xlHAlignCenter
..Value = "Standard Equipment"
..Font.Size = 10
'.Font.Bold = True
End With
With excBk.Worksheets(ndx).Range("rngReqd")
..HorizontalAlignment = xlHAlignCenter
..Value = "Must Select One from Each Box"
..Font.Size = 10
..Font.Bold = True
End With
With excBk.Worksheets(ndx).Range("rngDesired")
..HorizontalAlignment = xlHAlignCenter
..Value = "Attachments-Factory Installed"
..Font.Size = 10
..Font.Bold = True
End With
With excBk.Worksheets(ndx).Range("rngField")
..HorizontalAlignment = xlHAlignCenter
..Value = "Attachments-Installed On-Site"
..Font.Size = 10
..Font.Bold = True
End With
' ChangeFormula ndx
row = excBk.Worksheets(ndx).Range("rngTerminusRw").Rows.row
For Each cell In excBk.Worksheets(ndx).Range("L28:L" & row)
booNegative = False
If Not IsEmpty(cell.Value) Then
strVal = cell.Value
If UCase(Right(strVal, 1)) = "X" Then
booNegative = True
strVal = Left(strVal, Len(strVal) - 1)
End If
dblCost = CalcCost(strVal)
strVal = dblCost
strVal = ConvCost(strVal, booNegative)
cell.Value = strVal
End If 'Not IsEmpty(cell.Value) Then
Next 'Each cell In excBk.Worksheets(ndx).Range("L28:L" & row)
End Sub
Public Function CalcCost(strVal As String)
Dim bytLen As Byte
Dim strCents As String
Dim str1000 As String
Dim strDollars As String
strCents = Mid(strVal, 1, 2)
str1000 = Mid(strVal, 3, 1)
strDollars = Mid(strVal, 5)
CalcCost = Val(str1000 & strDollars & "." & strCents)
End Function
Public Function ConvCost(strVal As String, booNegative As Boolean)
Dim bytPeriodPos As Byte
Dim bytLen As Byte
Dim dblCost As Double
Dim strCents As String
Dim str1000 As String
Dim strDollars As String
dblCost = strVal
str1000 = Mid(dblCost, 1, 1)
' get position of decimal point
bytPeriodPos = InStr(Format(dblCost, "Fixed"), ".")
' 43,350.00 -> 400N3350
'4350.50->450N350
'435.75->475N35
'43.50->450N3
'4.30-> 430N
' get length of vals to go after alpha char
' if only one digit bytLen will = 0 and strDollars = ""
' so won't add to concatenation
If bytPeriodPos - 2 > 0 Then
bytLen = bytPeriodPos - 2
End If
strDollars = Mid(dblCost, 2, bytLen)
strCents = Right(Format(dblCost, "Fixed"), 2)
If booNegative Then
ConvCost = (str1000 & strCents & "N" & strDollars & "X")
Else
ConvCost = (str1000 & strCents & "N" & strDollars)
End If
End Function