Here is the code
Sub logic()
'Declaring variables
Dim r As Long, i As Long, k As Long, l As Long
Dim num() As Long
Dim del() As Long
'Assigning Values
r = 2
i = 0
k = 0
l = 0
ReDim num(0)
ReDim del(0)
Do Until Cells(r, 11).Value = ""
num(i) = Cells(r, 15).Value
'I m getting error over here
del(l) = k - num(i)
k = num(i)
i = i + 1
ReDim Preserve num(i)
'Preserve the value
r = r + 1
l = l + 1
Loop
r = 2
For l = 0 To UBound(num) - 1
Cells(r, 25).Value = del(l)
r = r + 1
Next l
End Sub
You are growing the num array but you forget to do the same with the del array. I believe you need to modify the code like this:
i = i + 1
ReDim Preserve num(i)
'Preserve the value
r = r + 1
l = l + 1
ReDim Preserve del(l) ' Add this line
Related
I want to sort below Two-digit array by VBA code
A 1
B 2
A 1
C 3
or below:
1 A
2 B
1 A
3 C
I have tried to sort them by Dictionary, but, Dictionary is not allowed to insert duplate key.
Is there any want to sort above array by number 1,2,3
I made this some time ago, it might help.
Function ArraySorter(ByVal RecArray As Variant, Optional ByVal RefCol As Integer = 0) As Variant
Dim Menor As String
Dim NewArray() As Variant
Dim i As Double, j As Double
Dim menorIndex As Double
Dim NewArrayIndex() As Double
Dim UsedIndex() As Double
ReDim NewArrayIndex(UBound(RecArray, 2))
ReDim NewArray(UBound(RecArray), UBound(RecArray, 2))
For i = 0 To UBound(NewArrayIndex)
NewArrayIndex(i) = -1
Next i
UsedIndex = NewArrayIndex
For i = 0 To UBound(RecArray, 2)
Menor = ""
menorIndex = -1
For j = 0 To UBound(RecArray, 2)
If UsedIndex(j) = -1 Then
If Menor = "" Then
Menor = RecArray(RefCol, j)
menorIndex = j
Else
If RecArray(RefCol, j) < Menor Then
Menor = RecArray(RefCol, j)
menorIndex = j
End If
End If
End If
Next j
UsedIndex(menorIndex) = 1
NewArrayIndex(i) = menorIndex
Next i
For i = 0 To UBound(NewArrayIndex)
For j = 0 To UBound(NewArray)
NewArray(j, i) = RecArray(j, NewArrayIndex(i))
Next j
Next i
ArraySorter = NewArray
End Function
If you have something like:
Function testArraySorter()
Dim myArr() As Variant
ReDim myArr(1, 3)
myArr(0, 0) = "A"
myArr(0, 1) = "B"
myArr(0, 2) = "A"
myArr(0, 3) = "C"
myArr(1, 0) = 1
myArr(1, 1) = 2
myArr(1, 2) = 1
myArr(1, 3) = 3
myArr = ArraySorter(myArr)
For i = 0 To UBound(myArr, 2)
Debug.Print myArr(0, i), myArr(1, i)
Next i
End Function
you'll get this in your immediate verification :
A 1
A 1
B 2
C 3
If you need to sort based in two or more columns, you could add a dummy column into your array, concatenate the criteria columns into it and then set this dummy column as RefCol: myArr = ArraySorter(myArr, addedColNumberHere).
Hope this helps.
I'm brand new to programming, and I figured VBA is a good place for me to start since I do a lot of work in Excel.
I created a macro that takes an integer from an input box (I've been using 2, 3 and 4 to test) and it creates a set of a 4-tier hierarchy of that number; e.g. entering "2" would produce
1.0.0.0
1.0.0.1
1.0.0.2
1.0.1.0
1.0.1.1
1.0.1.2 etc.
I got the macro to work as intended, but it takes forever to run. I think it's the offsets within the loops that are slowing it down. Does anyone have any suggestions to speed this up? Any general feedback is welcome as well.
Sub Tiers()
'Input Box
Dim Square As Integer
Square = InputBox("Enter Number of Tiers")
Range("f5").Select
Selection.Value = 0
With Application
.ScreenUpdating = False
End With
'Rows down
Dim g As Integer
Dim h As Integer
Dim i As Integer
Dim j As Integer
'Start For loops
For g = 1 To Square
For h = 0 To Square
For i = 0 To Square
For j = 0 To Square
'calculate offsets and place values of loop variables
Dim step As Long
step = ((g - 1) * (Square + 1) ^ 3 - 1 + (h * (Square + 1) ^ 2) + Square * i + i + j + 1)
Selection.Offset(step, 0).Value = j
Selection.Offset(step, -1).Value = i
Selection.Offset(step, -2).Value = h
Selection.Offset(step, -3).Value = g
Next j
Next i
Next h
Next g
With Application
.ScreenUpdating = True
End With
End Sub
Thanks
Further to my comment below your post, looping and writing to sheets like this will be too slow. Write to an array and then write the array to worksheet. This ran in a blink of an eye.
Is this what you are trying?
Sub Sample()
Dim TempArray() As Long
Dim n As Long
Dim g As Long, h As Long, i As Long, j As Long
Dim reponse As Variant
'~~> Accept only numbers
reponse = Application.InputBox(Prompt:="Enter Number of Tiers", Type:=1)
If reponse <> False Then
For g = 1 To reponse
For h = 0 To reponse
For i = 0 To reponse
For j = 0 To reponse
n = n + 1
Next j
Next i
Next h
Next g
ReDim Preserve TempArray(1 To n, 1 To 4)
n = 1
For g = 1 To reponse
For h = 0 To reponse
For i = 0 To reponse
For j = 0 To reponse
TempArray(n, 1) = g
TempArray(n, 2) = h
TempArray(n, 3) = i
TempArray(n, 4) = j
n = n + 1
Next j
Next i
Next h
Next g
'~~> Replace this with the relevant sheet
Sheet1.Range("A1").Resize(UBound(TempArray), 4).Value = TempArray
End If
End Sub
Screenshot:
The step calculation seems superfluous:
step = ((g - 1) * (Square + 1) ^ 3 - 1 + (h * (Square + 1) ^ 2) + Square * i + i + j + 1)
Try the following:
Sub Tiers()
'Input Box
Dim Square As Long
Square = InputBox("Enter Number of Tiers")
With Application
.ScreenUpdating = False
End With
'Rows down
Dim g As Long
Dim h As Long
Dim i As Long
Dim j As Long
Dim step As Long
step = 1
For g = 1 To Square
For h = 0 To Square
For i = 0 To Square
For j = 0 To Square
Range("F5").Offset(step, 0).Value = j
Range("F5").Offset(step, -1).Value = i
Range("F5").Offset(step, -2).Value = h
Range("F5").Offset(step, -3).Value = g
step = step + 1
Next j
Next i
Next h
Next g
With Application
.ScreenUpdating = True
End With
End Sub
Never used VBA before and basically just trying write this sub:
Sub Populate_Empties()
Dim i As Integer
Dim j As Integer
Dim n As Integer
Dim m As Integer
Dim k As Integer
' test for 50 rows...then change i from 2 to 278970
m = 2
For k = 3 To 8
For i = 2 To 50
If (IsEmpty(Cells(i, k).Value)) Then
m = i 'any statement
Else
j = i - 1
For n = m To j
Cells(n, k).Value = Cells(i, k).Value
m = i + 1
End If
End Sub
I keep getting error End If without Block
Any suggestions?
You're missing the closing statements on your for loops
Sub Populate_Empties()
Dim i As Integer
Dim j As Integer
Dim n As Integer
Dim m As Integer
Dim k As Integer
' test for 50 rows...then change i from 2 to 278970
m = 2
For k = 3 To 8
For i = 2 To 50
If (IsEmpty(Cells(i, k).Value)) Then
m = i 'any statement
Else
j = i - 1
For n = m To j
Cells(n, k).Value = Cells(i, k).Value
Next n
m = i + 1
End If
Next i
Next k
End Sub
What would be the VBA code to remove blank cells randomly placed in a spreadsheet.
Input
ColA ColB ColC ColD ColE
A B D
H J I
F B O
Output Should be like:
ColA ColB ColC ColD ColE
A B D
H J I
F B O
This solution is very fast and is free from the three caveats listed in my comment below the OP question:
Public Sub CullValues()
Dim i&, j&, k&, v
v = ActiveSheet.UsedRange
For i = 1 To UBound(v, 1)
k = 0
For j = 1 To UBound(v, 2)
If Len(v(i, j)) Then
k = k + 1
v(i, k) = v(i, j)
If j > k Then v(i, j) = Empty
End If
Next
Next
[a1].Resize(UBound(v, 1), UBound(v, 2)) = v
End Sub
You should really post at least an attempt of writing the code yourself.
That said, below is a working solution.
Option Explicit
Sub remove_blanks()
Dim lrow As Long, lcol As Long, i As Long, j As Long, k As Long, r As Long
Dim arrData() As Variant
Dim wb As Workbook, ws As Worksheet, myrng As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
' Range can be made dynamic
Set myrng = ws.Range("A1:BR103068")
arrData = myrng.Value
For i = LBound(arrData, 1) To UBound(arrData, 1)
r = 0
For j = LBound(arrData, 2) To UBound(arrData, 2)
If arrData(i, j) = Empty Then
For k = j To UBound(arrData, 2) - 1
arrData(i, k) = arrData(i, k + 1)
Next k
' Last element emptied after first loop
If k = UBound(arrData, 2) And r = 0 Then
arrData(i, k + r) = Empty
End If
r = r + 1 ' counts how many empty elements removed
End If
' Exits loop after spaces removed from iteration
If j + r = UBound(arrData, 2) Then
Exit For
End If
' Accounts for consecutive empty array elements
If arrData(i, j) = Empty Then
j = j - 1
End If
Next j
Next i
myrng.ClearContents
myrng.Value = arrData
End Sub
I haven't tested #Excel Hero's, but it doesn't look like it shifts all elements up the array when it finds an empty element. The below will move all elements, and then iterate to the next empty element, until it reaches a point where all elements in that item have been assessed.
Testing on 70 columns and 100,000 rows of data, the code took 80 seconds to complete.
I am trying to write a general code for matrix multiplication but when I am trying to verify it, the output is always a null matrix. So it seems that the values of the temp matrix are not getting updated.
Please suggest some changes for it to work. The code is copied below:
Public Function matrixmultiply(x() As Double, y() As Double) As Double()
Dim nrow1 As Integer, nrow2 As Integer, ncol1 As Integer, ncol2 As Integer, i As Integer, j As Integer, k As Integer, temp() As Double
nrow1 = UBound(x, 1) - LBound(x, 1) + 1
ncol1 = UBound(x, 2) - LBound(x, 2) + 1
nrow2 = UBound(y, 1) - LBound(y, 1) + 1
ncol2 = UBound(y, 2) - LBound(y, 2) + 1
ReDim matrixmultiply(1 To nrow1, 1 To ncol2)
ReDim temp(1 To nrow1, 1 To ncol2)
For i = 1 To nrow1
For j = 1 To ncol2
d = 2
For k = 1 To col1
temp(i, j) = temp(i, j) + x(i, k) * y(k, j)
Next k
Next j
Next i
matrixmultiply = temp
End Function
Private Sub CommandButton1_Click()
Dim x(1 To 3, 1 To 3) As Double, y(1 To 3, 1 To 3) As Double, z() As Double
Dim i As Integer, j As Integer
For i = 1 To 3
For j = 1 To 3
x(i, j) = Cells(i, j).Value
y(i, j) = Cells(i, j + 5).Value
Next j
Next i
z = matrixmultiply(x, y)
For i = 1 To 3
For j = 1 To 3
Cells(i, j + 12).Value = z(i, j)
Next j
Next i
End Sub
Silly mistake in the line:
For k = 1 To col1
It should, instead, be
For k = 1 To ncol1
Using Option Explicit would have saved a lot of hurt!