I am trying to export data from a excel to word but something goes wrong at the begging of the while statement. For some reason I get an error at the line ReDim Preserve zPList(zIndex) As personClass, the error is Subscript out of range.
Can someone help please?
Public Sub GetExcelData(ByRef zPList() As personClass, ByRef zIndex As Integer)
Dim tempStr As String
tempStr = ""
Dim row As Integer
row = 2
While tempStr <> "zzz"
zindez = zIndex + 1
ReDim Preserve zPList(zIndex) As personClass
Set zPList(zIndex) = New personClass
Range("A" + CStr(row)).Select
zPList(zIndex).fname = ActiveCell.text
Range("B" + CStr(row)).Select
zPList(zIndex).lname = ActiveCell.text
Range("C" + CStr(row)).Select
zPList(zIndex).Email = ActiveCell.text
Range("D" + CStr(row)).Select
zPList(zIndex).phoneN = ActiveCell.text
row = row + 1
Range("A" + CStr(row)).Select
tempStr = ActiveCell.text
Wend
End Sub
Related
I need to find values and test few conditions and insert row into an Excel sheet(file is heavy 65 MB). I have 7 such sheets where I need to insert data. And the reference basedata sheet inside the same file is 75k+ rows(wsSrcREDW)
My code runs really slow. Can someone please suggest faster algorithm. Thanks
Edit: the part that runs really slow is not the array assignments but the insertion of row loop in the end. It takes more than 5 mins to find new accounts and insert information.
Dim Curr() As String
For Each c In wsSrcREDW.Range("J2:J" & lrow1).Cells
ReDim Preserve Curr(2 To c.Row)
Curr(c.Row) = c.Value
Next c
Dim Entity() As String
For Each c In wsSrcREDW.Range("C2:C" & lrow1).Cells
ReDim Preserve Entity(2 To c.Row)
Entity(c.Row) = c.Value
Next c
Dim M9() As String
For Each c In wsSrcREDW.Range("F2:F" & lrow1).Cells
ReDim Preserve M9(2 To c.Row)
M9(c.Row) = c.Value
Next c
''' ECL Wback
Set wsECLWMBB = wbREDWMBB.Sheets("ECL WBack")
lrowECLWOrg = wsECLWMBB.Range("A" & Rows.Count).End(xlUp).Row
Dim I7() As String
For Each c In wsSrcREDW.Range("S2:S" & lrow1).Cells
ReDim Preserve I7(2 To c.Row)
I7(c.Row) = c.Value
Next c
For i = 2 To UBound(I7)
Set c = wsECLWMBB.Range("B2:B" & lrowECLWOrg).Find(I7(i))
If c Is Nothing And Entity(i) = "MIB" Then
lrowECLW = wsECLWMBB.Range("A" & Rows.Count).End(xlUp).Row
wsECLWMBB.Range("A" & (lrowECLW + 1)).EntireRow.Insert
wsECLWMBB.Range("A" & (lrowECLW + 1)).Value = M9(i)
wsECLWMBB.Range("B" & (lrowECLW + 1)).Value = I7(i)
wsECLWMBB.Range("C" & (lrowECLW + 1)).Value = Curr(i)
wsECLWMBB.Range("D" & (lrowECLW + 1)).Formula = "=MID(B" & (lrowECLW + 1) & ",1,7)"
End If
Next i
Use a variant array. Fill it and write the whole array in one operation. The following code should do it.
Option Explicit
Sub TEST()
Dim dataSrcEDW As Variant, dataECLWMBB As Variant, dataNew As Variant
Dim wsSrcREDW As Worksheet, wsECLWMBB As Worksheet
Dim colEntity As Long, colCurr As Long, colM9 As Long, colI7 As Long
Dim iSrcRow As Long, iTargetRow As Long, iNewRow As Long
Dim bFound As Boolean
Dim rgNew As Range
dataSrcEDW = wsSrcREDW.Range("A1").CurrentRegion ' Retrives all the source data
dataECLWMBB = wsECLWMBB.Range("A1").CurrentRegion ' Retrieves all the target data
ReDim dataNew(0, 1 To 4) ' This will contain the new rows you are adding at the end of wsECLWMBB
' Identify the columnns of interest
colCurr = Asc("J") - 64: colEntity = Asc("C") - 64: colM9 = Asc("F") - 64: colI7 = Asc("S") - 64
For iSrcRow = 2 To UBound(dataSrcEDW, 1) ' Scane through the source
bFound = False
If dataSrcEDW(iSrcRow, colEntity) = "MIB" Then
For iTargetRow = 2 To UBound(dataECLWMBB, 1)
If dataSrcEDW(iSrcRow, colI7) = dataECLWMBB(iTargetRow, 2) Then
bFound = True
Exit For
End If
Next
If Not bFound Then ' Check if this is a duplicate add
For iNewRow = 1 To UBound(dataNew, 1)
If dataSrcEDW(iSrcRow, colI7) = dataNew(iNewRow, 2) Then
bFound = True
Exit For
End If
Next
End If
If Not bFound Then
dataNew = AddRowToArray(dataNew)
iNewRow = UBound(dataNew, 1)
dataNew(iNewRow, 1) = dataSrcEDW(iSrcRow, colM9)
dataNew(iNewRow, 2) = dataSrcEDW(iSrcRow, colI7)
dataNew(iNewRow, 3) = dataSrcEDW(iSrcRow, colCurr)
dataNew(iNewRow, 4) = "=MID(B" & UBound(dataECLWMBB, 1) + iNewRow & ",1,7)"
End If
End If
Next
' Write out the new rows
If UBound(dataNew, 1) > 0 Then
Set rgNew = wsECLWMBB.Range("A" & UBound(dataECLWMBB, 1) + 1).Resize(UBound(dataNew, 1), UBound(dataNew, 2))
rgNew = dataNew
End If
End Sub
Public Function AddRowToArray(vArray) As Variant
' Can't do a redim preserve on a multi dimensional array. Add a row manually.
Dim vNewArray As Variant, iRow As Long, iCol As Long
ReDim vNewArray(1 To UBound(vArray, 1) + 1, 1 To UBound(vArray, 2))
For iRow = 1 To UBound(vArray, 1)
For iCol = 1 To UBound(vArray, 2)
vNewArray(iRow, iCol) = vArray(iRow, iCol)
Next
Next
AddRowToArray = vNewArray
End Function
Currently I am trying to improve the performance of my VBA program, because it takes forever to perform some table operations.
During the programs runtime I am trying to store data in worksheets, but the write-operations take for ever and I would like to store this data dynamically instead of writing it into a worksheet to reduce the time it needs to run.
I was thinking about using arrays instead of the worksheets to store the data but I am not quite sure whether this will work because I do not know how many rows/columns my table exactly has.
Here my code, any help is appreciated!
Public row As Long
Public rowMax As Long
Public startRow As Integer
Public materialType As String
Public filter As String
Public col As Integer
Public colMax As Integer
Public isUsed As Boolean
Public a As Integer
Sub bestimmeObFelderGenutzt()
Debug.Print ("bestimmeObFelderGenutzt:begin" & " " & Now())
With Sheets("Sheet1")
filter = "I"
startRow = 2
rowMax = Sheets("Sheet1").Cells(.Rows.Count, "F").End(xlUp).row
colMax = Sheets("Sheet1").Cells(1, .Columns.Count).End(xlToLeft).Column
materialType = Sheets("Sheet1").Range(filter & startRow).Value
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Nutzung"
For col = 1 To colMax
Sheets("Nutzung").Cells(1, col + 2).Value = Sheets("Sheet1").Cells(1, col).Value
Next col
For row = 2 To rowMax
Sheets("Nutzung").Range("A" & row).Value = Sheets("Sheet1").Range("A" & row).Value
Sheets("Nutzung").Range("B" & row).Value = Sheets("Sheet1").Range("I" & row).Value
For col = 1 To colMax
If IsEmpty(Sheets("Sheet1").Cells(row, col)) = False Then
isUsed = True
Sheets("Nutzung").Cells(row, col + 2).Value = 1
Else:
Sheets("Nutzung").Cells(row, col + 2).Value = 0
End If
Next col
Next row
End With
Debug.Print ("bestimmeObFelderGenutzt:end" & " " & Now())
End Sub
Sub findeUngenutzteSpalten(ByVal materialType As String, pos As Integer)
Debug.Print ("findeUngenutzteSpalten:begin" & " " & materialType & " " & Now())
With Sheets(materialType)
rowMax = Sheets(materialType).Cells(.Rows.Count, "F").End(xlUp).row
colMax = Sheets(materialType).Cells(1, .Columns.Count).End(xlToLeft).Column
Sheets("Auswertung").Cells(1, 1).Value = "Spaltenüberschrift:"
Dim a As Integer
For a = 1 To colMax
Sheets("Auswertung").Cells(a + 1, 1).Value = Sheets("Sheet1").Cells(1, a).Value
Next a
Sheets("Auswertung").Cells(1, pos + 1).Value = materialType
For col = 3 To colMax
For row = 2 To rowMax
If Sheets(materialType).Cells(row, col).Value = 1 Then
Sheets("Auswertung").Cells(col - 1, pos + 1).Value = "Ja"
GoTo WeiterCol
Else:
If row = rowMax Then
Sheets("Auswertung").Cells(col - 1, pos + 1).Value = "Nein"
Else:
GoTo WeiterRow
End If
End If
WeiterRow:
Next row
WeiterCol:
Next col
End With
Debug.Print ("findeUngenutzteSpalten:end" & " " & materialType & " " & Now())
End Sub
Sub kopiereZeilen(ByVal materialType As String)
Debug.Print ("kopiereZeilen:begin" & " " & materialType & " " & Now())
With Sheets("Nutzung")
rowMax = Sheets("Nutzung").Cells(.Rows.Count, "F").End(xlUp).row
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = materialType
Sheets("Nutzung").Cells(1, 1).EntireRow.Copy Sheets(materialType).Cells(1, 1)
Dim unusedRow As Long
For row = 2 To rowMax
unusedRow = Sheets(materialType).Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).row
If Sheets("Nutzung").Cells(row, 2).Value = materialType Then
Sheets("Nutzung").Cells(row, 2).EntireRow.Copy Sheets(materialType).Cells(unusedRow, 1)
End If
Next row
End With
Debug.Print ("kopiereZeilen:end" & " " & materialType & " " & Now())
End Sub
Sub allesZusammen()
Debug.Print ("Hauptaufruf:begin" & " " & Now())
Dim types(10) As String
Dim element As Variant
Dim pos As Integer
bestimmeObFelderGenutzt
types(0) = "A"
types(1) = "B"
types(2) = "C"
types(3) = "D"
types(4) = "E"
types(5) = "F"
types(6) = "G"
types(7) = "H"
types(8) = "I"
types(9) = "J"
types(10) = "K"
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = "Auswertung"
For Each element In types
kopiereZeilen (element)
pos = Application.Match(element, types, False)
findeUngenutzteSpalten element, pos
Next element
Debug.Print ("Hauptaufruf:end" & " " & Now())
End Sub
You can declare dynamic arrays. The general syntax is:
Dim Values() As Long
To use the array, you must first re-dimension it to the size you want. For example this declares a two-dimensional array of 3 x 5 values (zero based):
ReDim Values(2, 4)
If you want to size based on variables then use something like:
ReDim Values(myrowsize, mycolumnsize)
You can grow (or shrink) the array dynamically by using this syntax:
ReDim Preserve Values(2, mynewsize)
Note, that you can only re-dimension the last index of the array. So this is not allowed:
ReDim Preserve Values(mynewsize, 4)
But this is probably ok in your case, as you have a fixed number of columns.
It is perfectly ok to declare the dynamic array as a UDT. For example:
Type UDTInfo
valueA As Long
valueB As Long
End Type
Sub test()
Dim Values() As UDTInfo
ReDim Values(2, 4)
ReDim Preserve Values(2, 5)
End Sub
You can access the array in the normal way:
x = Values(1, 2)
You can copy one dynamic array to another directly, as long as the types and number of dimensions match (size doesn't matter):
Dim Values() As Integer
Dim Results() As Integer
Results = Values
And lastly, you can pass dynamic arrays to and from functions in the following way:
Function SomeFunc(ByRef Values() As Long) As Long()
Dim ReturnValues() As Long
ReturnValues = Values
SomeFunc = ReturnValues
End Function
Note, you only pass dynamic arrays ByRef but not ByVal.
I have created a nested for loop to compare 3 different cell values within 2 sheets. The loop works fine when the data is small, but when I run on 5,000 rows its too slow and crashes excel. Any idea of how to run this more efficiently.
Sub RowMatch()
Dim x As Integer
' Make sure we are in the right sheet
Worksheets("Q416").Activate
' Set numrows = number of rows of data.
NumRows = Range("C2", Range("C2").End(xlDown)).Rows.count
' find the reference range
Worksheets("Q415").Activate
NumRows2 = Range("C5", Range("C5").End(xlDown)).Rows.count
Worksheets("Q416").Activate
MsgBox ("Total # of Rows on this sheet = " & NumRows & " and " & NumRows2 & " in Ref Range")
Range("A1").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
'MsgBox NumRows2
For y = 1 To NumRows2
'MsgBox (ActiveCell.Offset(x, 0).Value & " & " & Worksheets("Q415").Cells(y + 1, 1))
If ActiveCell.Offset(x, 0).Value = Worksheets("Q415").Cells(y + 1, 1).Value _
And ActiveCell.Offset(x, 2).Value = Worksheets("Q415").Cells(y + 1, 3).Value Then
If ActiveCell.Offset(x, 5).Value = Worksheets("Q415").Cells(y + 1, 6).Value Then
'If NumRows(i).Value = ActiveCell.Offset(1, 0).Value Then
ActiveCell.Offset(x, 10).Value = "Same"
Else
ActiveCell.Offset(x, 10).Value = ActiveCell.Offset(x, 5).Value - Worksheets("Q415").Cells(y + 1, 6).Value
End If
End If
Next y
Next x
End Sub
Reading and writing to cells is one of the slowest operations you can do in Excel VBA. Instead, you should place the values contained in the worksheets into arrays and work with them there, Here is an excellent reference: http://www.cpearson.com/excel/ArraysAndRanges.aspx. Use your NumRows variables and either a column letter or number to define the ranges that will consitute the arrays e.g:
myRange = Range("A1:C" & NumRows)
myArray = myRange.value
From the link to Chip Pearsons site:
Dim Arr() As Variant
Arr = Range("A1:B10")
Dim R As Long
Dim C As Long
For R = 1 To UBound(Arr, 1) ' First array dimension is rows.
For C = 1 To UBound(Arr, 2) ' Second array dimension is columns.
Debug.Print Arr(R, C)
Next C
Next R
I have a macro to fill dates background if they are not forward than today. It works nicely but, however, just in one page, DateValues are not compared correctly.
I tried to show the result with MessageBoxes, it says 16.06.2016 is bigger than 29.10.2016
My macro:
Sub DolguRenkleri(ByVal StartIndex As Integer, ByVal EndIndex As Integer)
Dim Tarih As String
Dim Formul As String
Dim Formul2 As String
Tarih = Left(Now, 10)
For i = StartIndex To EndIndex - 1
MsgBox (Cells(i, 2).Value > DateValue(Tarih))
If Cells(i, 2) <= DateValue(Tarih) Then
With Range("A" + CStr(i), "H" + CStr(i))
.Interior.ColorIndex = 6
End With
Formul = "=TOPLA(D" + CStr(i + 1) + ":D" + CStr(EndIndex - 1) + ")"
Formul2 = "=F6-A" + CStr(i)
Else: With Range("A" + CStr(i), "H" + CStr(i))
.Interior.ColorIndex = 2
End With
End If
Next i
Range("F1").FormulaLocal = Formul
Range("F7").FormulaLocal = Formul2
End Sub
it must be that "16.06.2016" string in cell B10 is not recognized as a real Date value, notwithstanding you may have selected that cell and assigned it a "Date" format
in this case, use
If DateValue(Replace(Cells(i, 2).Value, ".", "/")) <= DateValue(Tarih) Then
I have created a data table through Sharperlight reporting thats generates its results into excel as shown below:-
What I want to do is develop a macro that will subtotal all categories for the data. There is no determined length size of the table other than it will always be columns G - J.
This way my hope is when a user refreshes the table using the menu on the side they will then be able to run a macro to get a quick one line total for each category.
Can anyone help with this???
Right click on the sheet1 tab > View Code
paste this code
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 4 Then
If Target.Row = 4 Or Target.Row = 5 Or Target.Row = 6 Then Totals
End If
End Sub
then add a module right click Sheet1 in the Project Explorer in the VBE window and Insert > Module
then pate this code
Sub Totals()
Range("C10:D" & Range("C10:C" & Rows.Count).End(xlDown).Row).ClearContents
Dim startAtRow As Long
startAtRow = 10 ' Set starting row
Dim lr As Long, i As Long, j As Long
lr = Range("J" & Rows.Count).End(xlUp).Row
ReDim arr(lr - 4) As String
For i = 5 To lr
arr(i - 5) = Range("J" & i).Value
Next i
Dim arr2() As String
arr2 = arr
RemoveDuplicate arr
For i = LBound(arr) To UBound(arr) - 1
Range("C" & (i + startAtRow)).Value = arr(i)
For j = LBound(arr2) To UBound(arr2) - 1
If arr(i) = arr2(j) Then
Range("D" & (i + startAtRow)).Value = Range("D" & i + startAtRow).Value + Range("I" & (j + 5)).Value
End If
Next j
Next i
End Sub
Private Sub RemoveDuplicate(ByRef StringArray() As String)
Dim lowBound$, UpBound&, A&, B&, cur&, tempArray() As String
If (Not StringArray) = True Then Exit Sub
lowBound = LBound(StringArray): UpBound = UBound(StringArray)
ReDim tempArray(lowBound To UpBound)
cur = lowBound: tempArray(cur) = StringArray(lowBound)
For A = lowBound + 1 To UpBound
For B = lowBound To cur
If LenB(tempArray(B)) = LenB(StringArray(A)) Then
If InStrB(1, StringArray(A), tempArray(B), vbBinaryCompare) = 1 Then Exit For
End If
Next B
If B > cur Then cur = B: tempArray(cur) = StringArray(A)
Next A
ReDim Preserve tempArray(lowBound To cur): StringArray = tempArray
End Sub
Now every time user is changing the values of D4,D5,D6 your results should update. The categories will be displayed starting at C10 down, and the totals at D10 down. Looks like this ( sample version )