I have a run-time error. The code is about to compare two excels.
I want to check all elements compared, and the different cell values would be colored in file2.
But every time i run it gets 91.
Sub Compare()
Dim sh As Integer, ShName As String
Dim F1_Workbook As Workbook, F2_Workbook As Workbook
Dim iRow As Double, iCol As Double, iRow_Max As Double, iCol_Max As Double
Dim File1_Path As String, File2_Path As String, F1_Data As String, F2_Data As String
File1_Path = ThisWorkbook.Sheets(1).Cells(2, 2)
File2_Path = ThisWorkbook.Sheets(1).Cells(3, 2)
iRow_Max = ThisWorkbook.Sheets(1).Cells(4, 2)
iCol_Max = ThisWorkbook.Sheets(1).Cells(5, 2)
Set F2_Workbook = Workbooks.Open(File2_Path)
Set F1_Workbook = Workbooks.Open(File1_Path)
ThisWorkbook.Sheets(1).Cells(7, 2) = F1_Workbook.Sheets.Count 'At this point, the code say 91 rte
For sh = 1 To F1_Workbook.Sheets.Count
ShName = F1_Workbook.Sheets(sh).Name
ThisWorkbook.Sheets(1).Cells(7 + sh, 1) = ShName
ThisWorkbook.Sheets(1).Cells(7 + sh, 2) = "Identical Sheets"
ThisWorkbook.Sheets(1).Cells(7 + sh, 2).Interior.Color = vbGreen
For iRow = 1 To iRow_Max
For iCol = 1 To iCol_Max
F1_Data = F1_Workbook.Sheets(ShName).Cells(iRow, iCol)
F2_Data = F2_Workbook.Sheets(ShName).Cells(iRow, iCol)
If F1_Data <> F2_Data Then
F1_Workbook.Sheets(ShName).Cells(iRow, iCol).Interior.Color = vbRed
ThisWorkbook.Sheets(1).Cells(8 + sh, 2) = "Mismatch Found"
ThisWorkbook.Sheets(1).Cells(8 + sh, 2).Interior.Color = vbRed
End If
Next iCol
Next iRow
Next sh
End Sub
I find the misstake. The name off the two files was the same.
Related
I try to work on a Project but it seems that it's far from my ability.
I need to Compare 2 workbooks containing 3 sheets ("WireList", "Cumulated BOM" and "BOM"), when I Browse File 1 and File 2 all sheets should compare at the same time and give the result in the format below:
I try a lot of codes but I am still a beginner and I hope if possible someone can help
Thank you very Much
Code Examples 1 : (Just to compare)
Option Explicit
Sub Compare()
'Define Object for Excel Workbooks to Compare
Dim sh As Integer, shName As String
Dim F1_Workbook As Workbook, F2_Workbook As Workbook
Dim iRow As Double, iCol As Double, iRow_Max As Double, iCol_Max As Double
Dim File1_Path As String, File2_Path As String, F1_Data As String, F2_Data As String
'Assign the Workbook File Name along with its Path
File1_Path = ThisWorkbook.Sheets(1).Cells(1, 2)
File2_Path = ThisWorkbook.Sheets(1).Cells(2, 2)
iRow_Max = ThisWorkbook.Sheets(1).Cells(3, 2)
iCol_Max = ThisWorkbook.Sheets(1).Cells(4, 2)
Set F2_Workbook = Workbooks.Open(File2_Path)
Set F1_Workbook = Workbooks.Open(File1_Path)
ThisWorkbook.Sheets(1).Cells(6, 2) = F1_Workbook.Sheets.Count
'With F1_Workbook object, now it is possible to pull any data from it
'Read Data From Each Sheets of Both Excel Files & Compare Data
For sh = 1 To F1_Workbook.Sheets.Count
shName = F1_Workbook.Sheets(sh).Name
ThisWorkbook.Sheets(1).Cells(7 + sh, 1) = shName
ThisWorkbook.Sheets(1).Cells(7 + sh, 2) = "Identical Sheets"
ThisWorkbook.Sheets(1).Cells(7 + sh, 2).Interior.Color = vbGreen
For iRow = 1 To iRow_Max
For iCol = 1 To iCol_Max
F1_Data = F1_Workbook.Sheets(shName).Cells(iRow, iCol)
F2_Data = F2_Workbook.Sheets(shName).Cells(iRow, iCol)
'Compare Data From Excel Sheets & Highlight the Mismatches
If F1_Data <> F2_Data Then
F1_Workbook.Sheets(shName).Cells(iRow, iCol).Interior.Color = vbYellow
ThisWorkbook.Sheets(1).Cells(7 + sh, 2) = "Mismatch Found"
ThisWorkbook.Sheets(1).Cells(7 + sh, 2).Interior.Color = vbYellow
End If
Next iCol
Next iRow
Next sh
'Process Completed
ThisWorkbook.Sheets(1).Activate
MsgBox "Task Completed - Thanks for Visiting OfficeTricks.Com"
End Sub
Code Example 2 :
Option Explicit
Sub test_CompareSheets_Adv()
ActiveWorkbook.Activate
If SheetExists("results") = False Then
Sheets.Add
ActiveSheet.Name = "results"
End If
If CompareSheets_Adv("Sheet3", "Sheet4") = True Then
MsgBox " Completed Successfully!"
Else
MsgBox "Process Failed"
End If
End Sub
Function CompareSheets_Adv(sh1Name$, sheet2name$) As Boolean
Dim vstr As String
Dim vData As Variant
Dim vitm As Variant
Dim vArr As Variant
Dim v()
Dim a As Long
Dim b As Long
Dim c As Long
On Error GoTo CompareSheetsERR
vData = Sheets(sh1Name$).Range("A1:T6817").Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
ReDim v(1 To UBound(vData, 2))
For a = 2 To UBound(vData, 1)
For b = 1 To UBound(vData, 2)
vstr = vstr & Chr(2) & vData(a, b)
v(b) = vData(a, b)
Next
.Item(vstr) = v
vstr = ""
Next
vData = Sheets(sheet2name$).Range("A1:T6817").Value
For a = 2 To UBound(vData, 1)
For b = 1 To UBound(vData, 2)
vstr = vstr & Chr(2) & vData(a, b)
v(b) = vData(a, b)
Next
If .exists(vstr) Then
.Item(vstr) = Empty
Else
.Item(vstr) = v
End If
vstr = ""
Next
For Each vitm In .keys
If IsEmpty(.Item(vitm)) Then
.Remove vitm
End If
Next
vArr = .items
c = .Count
End With
With Sheets("Results").Range("a1").Resize(, UBound(vData, 2))
.Cells.Clear
.Value = vData
If c > 0 Then
.Offset(1).Resize(c).Value = Application.Transpose(Application.Transpose(vArr))
End If
End With
CompareSheets_Adv = True
Exit Function
CompareSheetsERR:
CompareSheets_Adv = False
End Function
Function SheetExists(shName As String) As Boolean
With ActiveWorkbook
On Error Resume Next
SheetExists = (.Sheets(shName).Name = shName)
On Error GoTo 0
End With
End Function
I need to pass the variables max, min, and their respective locations to another sub where it will format each max and min in their respective column. I am trying to create an array that will store the locations and the values but its not working.
I was told to first identify the number of columns used and the number of rows, which is the beginning.
Rows = wsData.UsedRange.Rows.Count
Columns = wsData.UsedRange.Col.Count
j = 1
ReDim Min(j)
With wsData.Range("A3:A19")
For j = 1 To 19 'colum
Min(j) = WorksheetFunction.Min(Range(.Offset(1, j), .Offset(Row, j)))
Max = WorksheetFunction.Max(Range(.Offset(1, j), .Offset(Row, j)))
Min(j) = Min
j = j + 1
ReDim Preserve Min(j) 'saves variables
Next 'next column
End With
The code below uses the ActiveSheet which you need to change to reference the worksheet for your data. Additionally, it assumes that your data starts with Row 1. The code looks at each column in the range and stores the minimum/maximum (it does not account for multiple cells which may share the min or max value) value found in the column as well as the cell's address, in an array and then passes the array to two different subs, one which simply displays the information in a message and one which formats the the background color of the cells. This code does not perform any kind of error handling, but should get you where you want to go.
the line Option Explicit requires that all of the variables be defined using a Dim statement
the line Option Base 1 makes the default starting point for arrays 1 instead of 0
Option Explicit
Option Base 1
Sub GatherData()
Dim iRows As Long
Dim iCols As Long
Dim j As Long
Dim iMin() As Variant
Dim iMax() As Variant
Dim R As Range
iRows = ActiveSheet.UsedRange.Rows.Count
iCols = ActiveSheet.UsedRange.Columns.Count
ReDim iMin(iCols, 2)
ReDim iMax(iCols, 2)
For j = 1 To iCols
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Min(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
iMin(j, 1) = R.Value
iMin(j, 2) = R.Address
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Max(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
iMax(j, 1) = R.Value
iMax(j, 2) = R.Address
Next j
ListMinMax iMax(), True
ListMinMax iMin(), False
FormatMinMax iMax, "green"
FormatMinMax iMin, "yellow"
Set R = Nothing
End Sub
Sub ListMinMax(ByRef Arr() As Variant, ByVal MinMax As Boolean)
Dim strOutput As String
Dim i As Long
If MinMax = True Then
strOutput = "Maximums:" & vbCrLf & vbCrLf
Else
strOutput = "Minimums:" & vbCrLf & vbCrLf
End If
For i = 1 To UBound(Arr, 1)
strOutput = strOutput & "Cell: " & Arr(i, 2) & " = " & Arr(i, 1) & vbCrLf
Next i
MsgBox strOutput, vbOKOnly
End Sub
Sub FormatMinMax(ByRef Arr() As Variant, ByVal BGColor As String)
Dim i As Long
Select Case UCase(BGColor)
Case "GREEN"
For i = 1 To UBound(Arr, 1)
ActiveSheet.Range(Arr(i, 2)).Interior.Color = vbGreen
Next i
Case "YELLOW"
For i = 1 To UBound(Arr, 1)
ActiveSheet.Range(Arr(i, 2)).Interior.Color = vbYellow
Next i
Case Else
MsgBox "Invalid Option", vbCritical
End Select
End Sub
======================================================================
The code below does away with the need for the arrays and formats the color of the min/max values as it finds them
Sub GatherData2()
Dim iRows As Long
Dim iCols As Long
Dim j As Long
Dim R As Range
iRows = ActiveSheet.UsedRange.Rows.Count
iCols = ActiveSheet.UsedRange.Columns.Count
For j = 1 To iCols
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Min(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
R.Interior.Color = vbYellow
Set R = Range(Cells(1, j), Cells(iRows, j)).Find(WorksheetFunction.Max(Range(Cells(1, j), Cells(iRows, j))), LookIn:=xlValues)
R.Interior.Color = vbGreen
Next j
Set R = Nothing
End Sub
VBA runtime 9 error subscript out of range on only one system works fine on all the systems( error near ubound and lbound)
This code worked fine for years later it is giving an error on only one system.
I have tried updating the excel software and changing the data types for irow and icolumn. Any help is appreciated.
Sub TechHR_Refresh_Staffing(sDate As String, sLocationName As String)
Dim ws As Worksheet
Dim rng As Range
Dim sOrderDate As String
Dim sProtocolHost As String, sQueryServlet As String, sEditType As String,
sMeasure As String
Dim sSheet As String, sTable As String
Dim sURL As String, sPost As String
Dim iRow As Long, iCol As Long, i As Long, j As Long
If (sLocationName = kLocation_Lamar1NRD) Then
sSheet = kSheet_StaffingData
sTable = kTable_StaffingTotals
ElseIf (sLocationName = kLocation_Lamar2NRD) Then
sSheet = kSheet_StaffingDataL2
sTable = kTable_StaffingTotalsL2
ElseIf (sLocationName = kLocation_Lamar1CP) Then
sSheet = kSheet_StaffingDataCP
sTable = kTable_StaffingTotalsCP
Else
sSheet = kSheet_StaffingDataCPL2
sTable = kTable_StaffingTotalsCPL2
End If
Set ws = MIRGetNamedSheet(sSheet)
ws.Columns(1).NumberFormat = "m/d/yyyy h:mm"
ws.Columns(2).NumberFormat = "#"
ws.Columns(3).NumberFormat = "#"
ws.Columns(4).NumberFormat = "0"
ws.Columns(5).NumberFormat = "0"
ws.Columns(6).NumberFormat = "0"
sOrderDate = Replace(sDate, "-", "")
sURL = kProtocolHost + kQueryServlet
sPost = "__JSScript=SOS_TempCalculator&__orderdate=" + sOrderDate +
"&__location=" + sLocationName
If WQ_RunQuery(sURL, sPost) Then
'Reading results and displaying them
Dim aResults() As String
Dim bHasResults As Boolean
iRow = 0
While WQ_ParseResults(aResults)
For i = LBound(aResults, 1) To UBound(aResults, 1)
iRow = iRow + 1
iCol = 1
For j = LBound(aResults, 2) To UBound(aResults, 2)
ws.Cells(iRow, iCol).Value = aResults(i, j)
iCol = iCol + 1
Next j
Next i
bHasResults = True
Wend
'Code error in the line below
iRow = UBound(aResults, 1) - LBound(aResults, 1) + 1
iCol = UBound(aResults, 2) - LBound(aResults, 2) + 1
Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(iRow, iCol))
ws.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = sTable
End If
Exit Sub
End Sub
Excel spreadsheet
I have a set of over 10,000 lines of text strings in column A (Input), and I need to get the number (in case there is only one) or a sum of both (in case there are two).
Code
Here is the VBA code I have:
Sub ExtractNumericStrings()
Dim rngTemp As Range
Dim strTemp As String
Dim currNumber1 As Currency
Dim currNumber2 As Currency
Dim lngTemp As Long
Dim lngPos As Long
Dim lngLastRow As Long
With ActiveSheet
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each rngTemp In .Cells(1, "A").Resize(lngLastRow, 1) ' Set Range to look at
strTemp = rngTemp.Value2 ' Get string value of each cell
lngTemp = Len(strTemp) 'Get length of string
currNumber1 = 0 ' Reset value
currNumber2 = 0 ' Reset value
' Get first number
currNumber1 = fncGetNumericValue(strTemp, 1) ' Strip out first number
' Get second number if exists
' First strip out first number
strTemp = Replace(strTemp, currNumber1, "")
If Len(strTemp) <> 0 Then
currNumber2 = fncGetNumericValue(strTemp, 1)
End If
' now paste to sheet
If currNumber1 <> 0 And currNumber2 <> 0 Then
rngTemp.Offset(0, 1).Value = currNumber1 + currNumber2
rngTemp.Offset(0, 2).Value = "sum of the numbers"
ElseIf currNumber1 <> 0 Then
rngTemp.Offset(0, 1).Value = currNumber1
End If
Next rngTemp
End With
Call MsgBox("Procedure Complete!", vbOKOnly + vbInformation, "Procedure Complete")
End Sub
Private Function fncGetNumericValue(strTemp As String, lngStart As Long) As Currency
Dim varTemp As Variant
Dim lngCount As Long
Dim lngTemp As Long
' Reset
lngCount = 1
lngTemp = 1
varTemp = ""
On Error Resume Next
If IsNumeric(Left(strTemp, lngCount)) Then
Do While IsNumeric(Left(strTemp, lngCount)) = True
varTemp = Left(strTemp, lngCount)
lngCount = lngCount + 1
If lngCount > Len(strTemp) Then
Exit Do
End If
Loop
Else
' First clear non-numerics from string
lngTemp = 1
Do While IsNumeric(Left(strTemp, 1)) = False
lngTemp = lngTemp + 1
strTemp = Mid(strTemp, 2, Len(strTemp) - 1)
If lngTemp > Len(strTemp) Then
Exit Do
End If
Loop
' Then extract second number if exists
If strTemp <> "" Then
Do While IsNumeric(Mid(strTemp, lngCount, 1)) = True
varTemp = Left(strTemp, lngCount)
lngCount = lngCount + 1
If lngCount > Len(strTemp) Then
Exit Do
End If
Loop
End If
End If
' Retrun Value
If IsNumeric(varTemp) Then
fncGetNumericValue = CCur(varTemp)
Else
fncGetNumericValue = 0
End If
End Function
Here is what I'm trying to do:
https://www.youtube.com/watch?v=EjHnJVxuWJA
I have very limited knowledge of VBA, so please excuse me if I ask any stupid question. Running this thing successfully will save me hips of time. thanks!
Something like this:
Private Sub extract_num()
Dim cell as Range
Dim ws as Worksheet: Set ws = Sheets("Sheet1") ' replace Sheet1 with ur sheet name
Dim lr as Long: Set lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim values() As String
Dim i as Byte
Dim temp as Double
For Each cell in ws.Range("A2:A" & lr)
If Not isEmpty(cell) Then
values = Split(cell, " ")
For i = LBound(values) to UBound(values)
values(i) = Replace(values(i), ",", ".")
If isNumeric(values(i)) Then
temp = temp + values(i)
End If
Next i
cell.Offset(0, 2) = temp
temp = 0
End If
Next cell
End Function
This is presuming:
a) Individual words and numbers are always separated by space "123 abc 321"
b) Commas "," are used as an arithmetic floatpoint separator ##,##
Slightly different approach from Rawrplus
Option Explicit
Sub UpdateTotals()
Dim aRawValues As Variant
Dim iLRow&, iRow&, iArr&
Dim dTotal#
With ThisWorkbook.Worksheets("Sheet1") '<-- Change the sheet name to your sheet
iLRow = .Cells(Rows.Count, 1).End(xlUp).Row ' Get row count
For iRow = 1 To iLRow ' Loop through all rows in the sheet
aRawValues = Split(.Range("A" & iRow).Value, " ") ' Create and array of current cell value
For iArr = LBound(aRawValues) To UBound(aRawValues) ' Loop through all values in the array
dTotal = dTotal + ReturnDouble(Replace(aRawValues(iArr), ",", ".")) ' Add the returned double to total
Next
.Range("B" & iRow).Value = dTotal ' Set value in column B
dTotal = 0# ' Reset total
Next
End With
End Sub
Function ReturnDouble(ByVal sTextToConvert As String) As Double
Dim iCount%
Dim sNumbers$, sCurrChr$
sNumbers = ""
For iCount = 1 To Len(sTextToConvert)
sCurrChr = Mid(sTextToConvert, iCount, 1)
If IsNumeric(sCurrChr) Or sCurrChr = "." Then
sNumbers = sNumbers & sCurrChr
End If
Next
If Len(sNumbers) > 0 Then
ReturnDouble = CDbl(sNumbers)
Else
ReturnDouble = 0#
End If
End Function
I was trying to find out how to declare a 2-Dimensional array but all of the examples I have found so far are declared with set integers. I'm trying to create a program that will utilize two 2-Dimensional arrays and then perform simple operations on those arrays (such as finding difference or percent). The arrays are populated by numbers in Excel sheets (one set of numbers is on Sheet1 and another set is on Sheet2, both sets have the same number of rows and columns).
Since I don't know how many rows or columns there are I was going to use variables.
Dim s1excel As Worksheet
Dim s2excel As Worksheet
Dim s3excel As Worksheet
Dim firstSheetName As String
Dim secondSheetName As String
Dim totalRow As Integer
Dim totalCol As Integer
Dim iRow As Integer
Dim iCol As Integer
Set s1excel = ThisWorkbook.ActiveSheet
' Open the "Raw_Data" workbook
Set wbs = Workbooks.Open(file_path & data_title)
wbs.Activate
ActiveWorkbook.Sheets(firstSheetName).Select
Set s2excel = wbs.ActiveSheet
' Find totalRow, totalColumn (assumes there's values in Column A and Row 1 with no blanks)
totalRow = ActiveSheet.Range("A1").End(xlDown).Row
totalCol = ActiveSheet.Range("A1").End(xlToRight).Column
Dim s2Array(totalRow, totalCol)
Dim s3Array(totalRow, totalCol)
For iRow = 1 To totalRow
For iCol = 1 To totalCol
s2Array(iRow, iCol) = Cells(iRow, iCol)
Next iCol
Next iRow
ActiveWorkbook.Sheets(secondSheetName).Select
Set s3excel = wbs.ActiveSheet
For iRow = 1 To totalRow
For iCol = 1 To totalCol
s3Array(iRow, iCol) = Cells(iRow, iCol)
Next iCol
Next iRow
When I attempt to run this I get a compile-time error at the Dim s2Array(totalRow, totalCol) saying that a constant expression is required. The same error occurs if I change it to Dim s2Array(1 To totalRow, 1 To totalCol). Since I don't know what the dimensions are from the get go I can't declare it like Dim s2Array(1, 1) because then I'll get an out-of-bounds exception.
Thank you,
Jesse Smothermon
In fact I would not use any REDIM, nor a loop for transferring data from sheet to array:
dim arOne()
arOne = range("A2:F1000")
or even
arOne = range("A2").CurrentRegion
and that's it, your array is filled much faster then with a loop, no redim.
You need ReDim:
m = 5
n = 8
Dim my_array()
ReDim my_array(1 To m, 1 To n)
For i = 1 To m
For j = 1 To n
my_array(i, j) = i * j
Next
Next
For i = 1 To m
For j = 1 To n
Cells(i, j) = my_array(i, j)
Next
Next
As others have pointed out, your actual problem would be better solved with ranges. You could try something like this:
Dim r1 As Range
Dim r2 As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
totalRow = ws1.Range("A1").End(xlDown).Row
totalCol = ws1.Range("A1").End(xlToRight).Column
Set r1 = ws1.Range(ws1.Cells(1, 1), ws1.Cells(totalRow, totalCol))
Set r2 = ws2.Range(ws2.Cells(1, 1), ws2.Cells(totalRow, totalCol))
r2.Value = r1.Value
Here's A generic VBA Array To Range function that writes an array to the sheet in a single 'hit' to the sheet. This is much faster than writing the data into the sheet one cell at a time in loops for the rows and columns... However, there's some housekeeping to do, as you must specify the size of the target range correctly.
This 'housekeeping' looks like a lot of work and it's probably rather slow: but this is 'last mile' code to write to the sheet, and everything is faster than writing to the worksheet. Or at least, so much faster that it's effectively instantaneous, compared with a read or write to the worksheet, even in VBA, and you should do everything you possibly can in code before you hit the sheet.
A major component of this is error-trapping that I used to see turning up everywhere . I hate repetitive coding: I've coded it all here, and - hopefully - you'll never have to write it again.
A VBA 'Array to Range' function
Public Sub ArrayToRange(rngTarget As Excel.Range, InputArray As Variant)
' Write an array to an Excel range in a single 'hit' to the sheet
' InputArray must be a 2-Dimensional structure of the form Variant(Rows, Columns)
' The target range is resized automatically to the dimensions of the array, with
' the top left cell used as the start point.
' This subroutine saves repetitive coding for a common VBA and Excel task.
' If you think you won't need the code that works around common errors (long strings
' and objects in the array, etc) then feel free to comment them out.
On Error Resume Next
'
' Author: Nigel Heffernan
' HTTP://Excellerando.blogspot.com
'
' This code is in te public domain: take care to mark it clearly, and segregate
' it from proprietary code if you intend to assert intellectual property rights
' or impose commercial confidentiality restrictions on that proprietary code
Dim rngOutput As Excel.Range
Dim iRowCount As Long
Dim iColCount As Long
Dim iRow As Long
Dim iCol As Long
Dim arrTemp As Variant
Dim iDimensions As Integer
Dim iRowOffset As Long
Dim iColOffset As Long
Dim iStart As Long
Application.EnableEvents = False
If rngTarget.Cells.Count > 1 Then
rngTarget.ClearContents
End If
Application.EnableEvents = True
If IsEmpty(InputArray) Then
Exit Sub
End If
If TypeName(InputArray) = "Range" Then
InputArray = InputArray.Value
End If
' Is it actually an array? IsArray is sadly broken so...
If Not InStr(TypeName(InputArray), "(") Then
rngTarget.Cells(1, 1).Value2 = InputArray
Exit Sub
End If
iDimensions = ArrayDimensions(InputArray)
If iDimensions < 1 Then
rngTarget.Value = CStr(InputArray)
ElseIf iDimensions = 1 Then
iRowCount = UBound(InputArray) - LBound(InputArray)
iStart = LBound(InputArray)
iColCount = 1
If iRowCount > (655354 - rngTarget.Row) Then
iRowCount = 655354 + iStart - rngTarget.Row
ReDim Preserve InputArray(iStart To iRowCount)
End If
iRowCount = UBound(InputArray) - LBound(InputArray)
iColCount = 1
' It's a vector. Yes, I asked for a 2-Dimensional array. But I'm feeling generous.
' By convention, a vector is presented in Excel as an arry of 1 to n rows and 1 column.
ReDim arrTemp(LBound(InputArray, 1) To UBound(InputArray, 1), 1 To 1)
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
arrTemp(iRow, 1) = InputArray(iRow)
Next
With rngTarget.Worksheet
Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount))
rngOutput.Value2 = arrTemp
Set rngTarget = rngOutput
End With
Erase arrTemp
ElseIf iDimensions = 2 Then
iRowCount = UBound(InputArray, 1) - LBound(InputArray, 1)
iColCount = UBound(InputArray, 2) - LBound(InputArray, 2)
iStart = LBound(InputArray, 1)
If iRowCount > (65534 - rngTarget.Row) Then
iRowCount = 65534 - rngTarget.Row
InputArray = ArrayTranspose(InputArray)
ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iRowCount)
InputArray = ArrayTranspose(InputArray)
End If
iStart = LBound(InputArray, 2)
If iColCount > (254 - rngTarget.Column) Then
ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iColCount)
End If
With rngTarget.Worksheet
Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount + 1))
Err.Clear
Application.EnableEvents = False
rngOutput.Value2 = InputArray
Application.EnableEvents = True
If Err.Number <> 0 Then
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
If IsNumeric(InputArray(iRow, iCol)) Then
' no action
Else
InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
InputArray(iRow, iCol) = Trim(InputArray(iRow, iCol))
End If
Next iCol
Next iRow
Err.Clear
rngOutput.Formula = InputArray
End If 'err<>0
If Err <> 0 Then
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
If IsNumeric(InputArray(iRow, iCol)) Then
' no action
Else
If Left(InputArray(iRow, iCol), 1) = "=" Then
InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
End If
If Left(InputArray(iRow, iCol), 1) = "+" Then
InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
End If
If Left(InputArray(iRow, iCol), 1) = "*" Then
InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
End If
End If
Next iCol
Next iRow
Err.Clear
rngOutput.Value2 = InputArray
End If 'err<>0
If Err <> 0 Then
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
If IsObject(InputArray(iRow, iCol)) Then
InputArray(iRow, iCol) = "[OBJECT] " & TypeName(InputArray(iRow, iCol))
ElseIf IsArray(InputArray(iRow, iCol)) Then
InputArray(iRow, iCol) = Split(InputArray(iRow, iCol), ",")
ElseIf IsNumeric(InputArray(iRow, iCol)) Then
' no action
Else
InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
If Len(InputArray(iRow, iCol)) > 255 Then
' Block-write operations fail on strings exceeding 255 chars. You *have*
' to go back and check, and write this masterpiece one cell at a time...
InputArray(iRow, iCol) = Left(Trim(InputArray(iRow, iCol)), 255)
End If
End If
Next iCol
Next iRow
Err.Clear
rngOutput.Text = InputArray
End If 'err<>0
If Err <> 0 Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
iRowOffset = LBound(InputArray, 1) - 1
iColOffset = LBound(InputArray, 2) - 1
For iRow = 1 To iRowCount
If iRow Mod 100 = 0 Then
Application.StatusBar = "Filling range... " & CInt(100# * iRow / iRowCount) & "%"
End If
For iCol = 1 To iColCount
rngOutput.Cells(iRow, iCol) = InputArray(iRow + iRowOffset, iCol + iColOffset)
Next iCol
Next iRow
Application.StatusBar = False
Application.ScreenUpdating = True
End If 'err<>0
Set rngTarget = rngOutput ' resizes the range This is useful, *most* of the time
End With
End If
End Sub
You will need the source for ArrayDimensions:
This API declaration is required in the module header:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
...And here's the function itself:
Private Function ArrayDimensions(arr As Variant) As Integer
'-----------------------------------------------------------------
' will return:
' -1 if not an array
' 0 if an un-dimmed array
' 1 or more indicating the number of dimensions of a dimmed array
'-----------------------------------------------------------------
' Retrieved from Chris Rae's VBA Code Archive - http://chrisrae.com/vba
' Code written by Chris Rae, 25/5/00
' Originally published by R. B. Smissaert.
' Additional credits to Bob Phillips, Rick Rothstein, and Thomas Eyde on VB2TheMax
Dim ptr As Long
Dim vType As Integer
Const VT_BYREF = &H4000&
'get the real VarType of the argument
'this is similar to VarType(), but returns also the VT_BYREF bit
CopyMemory vType, arr, 2
'exit if not an array
If (vType And vbArray) = 0 Then
ArrayDimensions = -1
Exit Function
End If
'get the address of the SAFEARRAY descriptor
'this is stored in the second half of the
'Variant parameter that has received the array
CopyMemory ptr, ByVal VarPtr(arr) + 8, 4
'see whether the routine was passed a Variant
'that contains an array, rather than directly an array
'in the former case ptr already points to the SA structure.
'Thanks to Monte Hansen for this fix
If (vType And VT_BYREF) Then
' ptr is a pointer to a pointer
CopyMemory ptr, ByVal ptr, 4
End If
'get the address of the SAFEARRAY structure
'this is stored in the descriptor
'get the first word of the SAFEARRAY structure
'which holds the number of dimensions
'...but first check that saAddr is non-zero, otherwise
'this routine bombs when the array is uninitialized
If ptr Then
CopyMemory ArrayDimensions, ByVal ptr, 2
End If
End Function
Also: I would advise you to keep that declaration private. If you must make it a public Sub in another module, insert the Option Private Module statement in the module header. You really don't want your users calling any function with CopyMemoryoperations and pointer arithmetic.
For this example you will need to create your own type, that would be an array. Then you create a bigger array which elements are of type you have just created.
To run my example you will need to fill columns A and B in Sheet1 with some values. Then run test(). It will read first two rows and add the values to the BigArr. Then it will check how many rows of data you have and read them all, from the place it has stopped reading, i.e., 3rd row.
Tested in Excel 2007.
Option Explicit
Private Type SmallArr
Elt() As Variant
End Type
Sub test()
Dim x As Long, max_row As Long, y As Long
'' Define big array as an array of small arrays
Dim BigArr() As SmallArr
y = 2
ReDim Preserve BigArr(0 To y)
For x = 0 To y
ReDim Preserve BigArr(x).Elt(0 To 1)
'' Take some test values
BigArr(x).Elt(0) = Cells(x + 1, 1).Value
BigArr(x).Elt(1) = Cells(x + 1, 2).Value
Next x
'' Write what has been read
Debug.Print "BigArr size = " & UBound(BigArr) + 1
For x = 0 To UBound(BigArr)
Debug.Print BigArr(x).Elt(0) & " | " & BigArr(x).Elt(1)
Next x
'' Get the number of the last not empty row
max_row = Range("A" & Rows.Count).End(xlUp).Row
'' Change the size of the big array
ReDim Preserve BigArr(0 To max_row)
Debug.Print "new size of BigArr with old data = " & UBound(BigArr)
'' Check haven't we lost any data
For x = 0 To y
Debug.Print BigArr(x).Elt(0) & " | " & BigArr(x).Elt(1)
Next x
For x = y To max_row
'' We have to change the size of each Elt,
'' because there are some new for,
'' which the size has not been set, yet.
ReDim Preserve BigArr(x).Elt(0 To 1)
'' Take some test values
BigArr(x).Elt(0) = Cells(x + 1, 1).Value
BigArr(x).Elt(1) = Cells(x + 1, 2).Value
Next x
'' Check what we have read
Debug.Print "BigArr size = " & UBound(BigArr) + 1
For x = 0 To UBound(BigArr)
Debug.Print BigArr(x).Elt(0) & " | " & BigArr(x).Elt(1)
Next x
End Sub