I am writing code to change the read the formatting of the cells in my worksheets. I got the code working using for loops but it takes too long running this way. So I am trying to rewrite the code using arrays . On the worksheet I am on now I have two tables that I have to loop through. Table 1 - B2:H14 Table 2 - AB2:AH14
Right now I am trying to get the first loop working. Currently the loop starts in cell B2 and stops at G2 then goes to H3 and gives me the run-time error 91.
Any help is appreciated
Tom
Right now I am trying to get the first loop working. Currently the loop starts in cell B2 and stops at G2 then goes to H3 and gives me the run-time error 91.
Any help is appreciated
Tom
Code:
Public Sub ChangeDecimalPlaces1()
Dim wrkbk As Excel.Workbook
Dim wrkSh As Excel.Worksheet
Dim intRound As Double
Dim intRound1 As Double
Dim intRound2 As Double
Dim dblDecPlaces As Double
Dim strType As String
Dim rngRound As Range
Dim strRange As String
Dim strFormat As String
Dim lngLastR As Long, lngCnt As Long
Dim varSrc As Variant, varComp As Variant, x
Dim rng1 As Range, rng2 As Range
Dim lngShCnt As Long
Dim lngShCntTot As Long
Dim strOutputData As String
Dim wrkShSrc As Excel.Worksheet
Dim wrkShComp As Excel.Worksheet
Dim wrkShOutput As Excel.Worksheet
Dim rngSrc As Range
Dim rngComp As Range
'Last Row Number for source table
Dim lngLastRowSrc As Long
'Last Column Number for source table
Dim lngLastColDataSrc As Long
'Last Column Number for compare table
Dim lngLastColDataComp As Long
'First column number for comparison table
Dim lngFirstColDataComp As Long
'Start Column for compare table
Dim lngStartColComp As Long
'First Column of compare table
Dim strFirstColComp As String
Dim strDataSrc As String
Dim lngFirstEmptyCol As Long
Dim strFirstEmptyCol As String
Dim strDataComp As String
Dim lngLastRowComp As Long
Dim lngLastRowOutput As Long
Dim lngRowSrc As Long
Dim lngColSrc As Long
Dim strSheet As String
Dim lngErrCnt As Long
Dim lngColComp As Long
Dim lngWksCnt As Long
Dim strHeader(10) As String
Dim lngLoop As Long
Dim col As Long
Dim C As Excel.Range
Dim R As Excel.Range
Dim lngColCnt As Long
Dim lngRowCnt As Long
Dim lngColumns As Long
Dim lngRows As Long
Dim lngHeader As Long
Dim lngStartColumnSrc As Long
Set wrkbk = ActiveWorkbook
Application.ScreenUpdating = False
'Loop based on headers
'header = "this one" ' header name to find
strHeader(1) = "BI"
strHeader(2) = "PD"
strHeader(3) = "MP"
strHeader(4) = "Comp"
strHeader(5) = "Coll"
strHeader(6) = "UM"
strHeader(7) = "Fixed"
strHeader(8) = "Sort"
lngShCntTot = wrkbk.Sheets.Count
For lngShCnt = 6 To lngShCntTot
Set wrkShSrc = Worksheets(lngShCnt)
Set wrkShComp = Worksheets(lngShCnt)
Worksheets(lngShCnt).Activate
' If ActiveSheet.Name = "Longevity_Mapping_018" Then Call TexttoCol
'Skip Sheets that don't have numbers to convert
Select Case ActiveSheet.Name
Case "Longevity_001"
strHeader(1) = "Factor"
Case "Longevity_002"
strHeader(1) = "Factor"
Case "Longevity_003"
GoTo 1
Case "Longevity_006"
strHeader(1) = "Factor"
Case "Longevity_007"
strHeader(1) = "Factor"
Case "Longevity_009"
strHeader(1) = "Factor"
Case "Longevity_010"
strHeader(1) = "Factor"
Case "Longevity_011"
strHeader(1) = "Factor"
Case "Longevity_012"
strHeader(1) = "Factor"
Case "Longevity_013"
strHeader(1) = "Factor"
Case "Longevity_014"
strHeader(1) = "Factor"
Case "Longevity_015"
strHeader(1) = "Factor"
Case "Longevity_016"
strHeader(1) = "Factor"
Case "Longevity_017"
strHeader(1) = "Factor"
Case "Longevity_018"
GoTo 1
Case "Longevity_Mapping_018"
GoTo 1
Case "Longevity_019"
strHeader(1) = "Factor"
Case "Policy_Mapping_001"
GoTo 1
Case "Tier_Mapping_045"
GoTo 1
Case "Tier_Caps_056"
GoTo 1
Case "Misc_001"
GoTo 1
Case "Misc_002"
GoTo 1
Case "Misc_003"
GoTo 1
Case "Misc_004"
GoTo 1
Case "Misc_005"
GoTo 1
Case "Misc_006"
GoTo 1
Case "Misc_007"
GoTo 1
Case "Misc_008"
GoTo 1
Case "Misc_009"
strHeader(1) = "Comp"
strHeader(2) = "Coll"
strHeader(3) = "Sort"
Case "Misc_010"
strHeader(1) = "Comp"
strHeader(2) = "Coll"
strHeader(3) = "Sort"
Case "Misc_011"
strHeader(4) = "Sort"
Case "Misc_014"
strHeader(1) = "Comp"
strHeader(2) = "Coll"
strHeader(3) = "Sort"
Case "Misc_015"
strHeader(1) = "Comp"
strHeader(2) = "Coll"
Case "Misc_016"
strHeader(1) = "Comp"
strHeader(2) = "Sort"
End Select
Debug.Print ActiveSheet.Name
Stop
Application.ScreenUpdating = False
'Determine Last Row and last Column of Current Worksheet
lngLastRowSrc = wrkShSrc.Range("A" & Rows.Count).End(xlUp).Row
lngLastColDataSrc = wrkShSrc.Range("Z1").End(xlToLeft).Column
strDataSrc = ColLtr(lngLastColDataSrc)
lngFirstEmptyCol = lngLastColDataSrc + 1
strFirstEmptyCol = ColLtr(lngFirstEmptyCol)
'Determine Last Row and Column of Comparison Range on same worksheet
lngLastColDataComp = wrkShComp.Range("AZ1").End(xlToLeft).Column
strDataComp = ColLtr(lngLastColDataComp)
lngFirstColDataComp = wrkShSrc.Range("Z1").End(xlToRight).Column + 1
strFirstColComp = ColLtr(lngFirstColDataComp)
lngLastRowComp = wrkShSrc.Range("AA" & Rows.Count).End(xlUp).Row
lngRowCnt = 0
lngColumns = 0
lngHeader = 0
' Stop
If wrkShSrc.Range("B1").Value = "BI" Then lngStartColumnSrc = 2
If wrkShSrc.Range("B1").Value = "Factor" Then lngStartColumnSrc = 2
If wrkShSrc.Range("B1").Value = "Comp" Then lngStartColumnSrc = 2
If wrkShSrc.Range("C1").Value = "BI" Then lngStartColumnSrc = 3
If wrkShSrc.Range("D1").Value = "BI" Then lngStartColumnSrc = 4
If wrkShSrc.Range("D1").Value = "Factor" Then lngStartColumnSrc = 4
If wrkShSrc.Range("E1").Value = "BI" Then lngStartColumnSrc = 5
'Loop through Source Columns of table
Dim Arr() As Variant
Stop
' Arr = Range("B" & lngStartColumnSrc & ":" & strDataSrc & lngLastRowSrc)
Arr = Range("B2:H14")
For lngRowCnt = LBound(Arr, 1) To UBound(Arr, 1) ' First array dimension is rows
For lngColCnt = LBound(Arr, 2) To UBound(Arr, 2) ' Second array dimension is columns
Debug.Print Arr(lngRowCnt, lngColCnt)
lngHeader = 1 + lngHeader
'Finds column header
Set C = wrkShSrc.Range("B1:" & strDataSrc & "1").Find(strHeader(lngHeader), LookIn:=xlValues)
' lngRowCnt = lngRows
[Blue] lngColCnt = C.Column [/Blue]
If lngRowCnt = 1 Then lngRowCnt = lngRowCnt + 1
Set rngRound = wrkShSrc.cells(lngRowCnt, lngColCnt)
' lngColCnt =
' Set c = ActiveSheet.Range("B1:" & strDataSrc & lngLastRowSrc).Find(strHeader(lngColumns), LookIn:=xlValues)
If Not C Is Nothing Then
If rngRound = 0 Then
strFormat = "0"
With wrkShSrc.cells(lngRowCnt, lngColCnt)
'Formats cell to amount of places that is needed
.NumberFormat = strFormat
.IndentLevel = 1
' .Value = Format(intRound, strFormat)
End With
End If
If rngRound <> 0 Then
With wrkShSrc.cells(lngRowCnt, lngColCnt)
'Formats cell to amount of places that is needed
' .NumberFormat = strFormat
' .IndentLevel = 1
'' .Value = Format(intRound, strFormat)
intRound = (rngRound)
' intRound = wrkSh.Range(rngRound).Value
'Get number of decimal places
dblDecPlaces = DigitCount(intRound)
dblDecPlaces = dblDecPlaces - 1
Call SetDecimalPlaces(dblDecPlaces, strFormat)
.NumberFormat = strFormat
.IndentLevel = 1
End With
End If
End If 'Not c Is Nothing Then
Next lngColCnt
Next lngRowCnt
lngHeader = 0
'Loop through Compare table
If wrkShSrc.Range("AB1").Value = "BI" Then lngStartColComp = 27
If wrkShSrc.Range("AB1").Value = "Factor" Then lngStartColComp = 27
If wrkShSrc.Range("AB1").Value = "Comp" Then lngStartColComp = 27
If wrkShSrc.Range("AC1").Value = "BI" Then lngStartColComp = 28
If wrkShSrc.Range("AD1").Value = "BI" Then lngStartColComp = 29
If wrkShSrc.Range("AE1").Value = "BI" Then lngStartColComp = 30
'Loop through Compare Columns of table
For lngColumns = lngStartColComp To lngLastColDataComp
lngHeader = lngHeader + 1
' Stop
' End If 'Not c Is Nothing Then
'Loop through rows
Debug.Print ActiveSheet.Name
For lngRows = 2 To lngLastRowComp
'Does not change rows
'Finds column header
Set C = wrkShComp.Range(strFirstColComp & "1:" & strDataComp & "1").Find(strHeader(lngHeader), LookIn:=xlValues)
lngRowCnt = lngRows
' lngRows = c.Row
lngRowCnt = lngRows
lngColCnt = C.Column
Set rngRound = wrkShComp.cells(lngRowCnt, lngColCnt)
strType = CellType(rngRound)
If strType <> "Number" Then
Else
'If Cell is a number
If rngRound = 0 Then
strFormat = "0"
With wrkShComp.cells(lngRowCnt, lngColCnt)
'Formats cell to amount of places that is needed
.NumberFormat = strFormat
.IndentLevel = 1
End With
Else
With wrkShComp.cells(lngRowCnt, lngColCnt)
intRound = (rngRound)
'Get number of decimal places
dblDecPlaces = DigitCount(intRound)
dblDecPlaces = dblDecPlaces - 1
Call SetDecimalPlaces(dblDecPlaces, strFormat)
.NumberFormat = strFormat
.IndentLevel = 1
End With
End If 'rngRound = 0
End If 'strType <> "Number"
End If 'Not c Is Nothing Then
Next lngRows
Next lngColumns
1:
Next lngShCnt
Application.ScreenUpdating = True
End Sub
