How to make an array empty in excel VBA - excel

Sub WriteToZeroBasedArray()
Dim E As Integer
Dim rCount As Long: rCount =
Worksheets("0618").Cells.SpecialCells(xlLastCell).Row
For E = 9 To rCount
Dim V() As Variant ' Note the parentheses!
Dim P() As Variant
Dim N() As Variant
Dim Index As Long
Dim Index_2 As Long
Dim Index_3 As Long
Dim cCount As Long: cCount = Worksheets("0618").Cells.SpecialCells(xlLastCell).Column ' e.g.
Dim c As Long '배열에 값 저장하기
For c = 7 To cCount
If 0 < Worksheets("0618").Cells(E, c).Value And Worksheets("0618").Cells(E, c).Value < 100 Then
ReDim Preserve V(Index)
' A safer way (Option Base related):
'ReDim Preserve V(0 To Index)
V(Index) = Worksheets("0618").Cells(2, c).Value
Index = Index + 1
ReDim Preserve P(Index_2)
P(Index_2) = Worksheets("0618").Cells(4, c).Value
Index_2 = Index_2 + 1
ReDim Preserve N(Index_3)
N(Index_3) = Worksheets("0618").Cells(E, c).Value
Index_3 = Index_3 + 1
End If
Next c
Dim K As Integer
Dim L As Integer
K = UBound(V) '배열의 값 차례로 Sheet2에 넣기
For L = 0 To K
If L < 5 Then
Worksheets("sheet2").Cells(L + 6 + 14 * (E - 9), 1).Value = V(L)
Worksheets("sheet2").Cells(L + 6 + 14 * (E - 9), 2).Value = P(L)
Worksheets("sheet2").Cells(L + 6 + 14 * (E - 9), 3).Value = N(L)
Else
Worksheets("sheet2").Cells(L + 1 + 14 * (E - 9), 5).Value = V(L)
Worksheets("sheet2").Cells(L + 1 + 14 * (E - 9), 6).Value = P(L)
Worksheets("sheet2").Cells(L + 1 + 14 * (E - 9), 7).Value = N(L)
End If
Next
Dim FP As Integer
Dim Sum As Integer
Sum = 0
'수량*단가 구하기
For FP = (6 + 14 * (E - 9)) To (10 + 14 * (E - 9))
Worksheets("sheet2").Cells(FP, 4).Value = Worksheets("sheet2").Cells(FP, 2).Value * Worksheets("sheet2").Cells(FP, 3).Value
Worksheets("sheet2").Cells(FP, 8).Value = Worksheets("sheet2").Cells(FP, 6).Value * Worksheets("sheet2").Cells(FP, 7).Value
'총액 구하기
Sum = Sum + Worksheets("sheet2").Cells(FP, 4).Value + Worksheets("sheet2").Cells(FP, 8).Value
'0 지우기
If Worksheets("sheet2").Cells(FP, 4).Value = 0 Then
Worksheets("sheet2").Cells(FP, 4).ClearContents
End If
If Worksheets("sheet2").Cells(FP, 8).Value = 0 Then
Worksheets("sheet2").Cells(FP, 8).ClearContents
End If
Next
'총액 구하기2
Worksheets("sheet2").Cells(12 + 14 * (E - 9), 8).Value = Sum
'받으실 분
Worksheets("sheet2").Cells(3 + 14 * (E - 9), 2).Value = Worksheets("0618").Cells(E, 3).Value
'주소
Worksheets("sheet2").Cells(3 + 14 * (E - 9), 5).Value = Worksheets("0618").Cells(E, 2).Value
'서식 복사'
Worksheets("sheet3").Range("A1:H13").Copy
Worksheets("sheet2").Range("A" & 15 + 14 * (E - 9)).PasteSpecial
Erase V, P, N
If Index = 0 Then Exit Sub
Next
Debug.Print Join(V, vbLf)
End Sub
I used "Erase V, P, N" at the last part of this code to make V,P,N into empty arrays, because the code has to repeat from E = 9 to E = Column number and as it repeats, these arrays has to be continuously empty at the last part of the code, to use them again at the next repeat.
But when I run this code, these arrays doesn't become empty. The values are accumulated more and more as the code repeats. I think maybe the code "Erase V, P, N" is the wrong code.
So Could anybody please tell me how to make the the arrays empty?

Related

How to erase previous values of arrays when repeating in excel vba

Sub WriteToZeroBasedArray()
Dim E As Integer
Dim rCount As Long: rCount = Worksheets("0618").Cells.SpecialCells(xlLastCell).Row
For E = 9 To 11
Dim V() As Variant ' Note the parentheses!
Dim P() As Variant
Dim N() As Variant
Dim Index As Long
Dim Index_2 As Long
Dim Index_3 As Long
Dim cCount As Long: cCount = Worksheets("0618").Cells.SpecialCells(xlLastCell).Column ' e.g.
Dim c As Long '배열에 값 저장하기
For c = 7 To cCount
If 0 < Worksheets("0618").Cells(E, c).Value And Worksheets("0618").Cells(E, c).Value < 100 Then
ReDim Preserve V(Index)
' A safer way (Option Base related):
'ReDim Preserve V(0 To Index)
V(Index) = Worksheets("0618").Cells(2, c).Value
Index = Index + 1
ReDim Preserve P(Index_2)
P(Index_2) = Worksheets("0618").Cells(4, c).Value
Index_2 = Index_2 + 1
ReDim Preserve N(Index_3)
N(Index_3) = Worksheets("0618").Cells(E, c).Value
Index_3 = Index_3 + 1
End If
Next c
Dim K As Integer
Dim L As Integer
K = UBound(V) '배열의 값 차례로 Sheet2에 넣기
For L = 0 To K
If L < 5 Then
Worksheets("sheet2").Cells(L + 6 + 14 * (E - 9), 1).Value = V(L)
Worksheets("sheet2").Cells(L + 6 + 14 * (E - 9), 2).Value = P(L)
Worksheets("sheet2").Cells(L + 6 + 14 * (E - 9), 3).Value = N(L)
Else
Worksheets("sheet2").Cells(L + 1 + 14 * (E - 9), 5).Value = V(L)
Worksheets("sheet2").Cells(L + 1 + 14 * (E - 9), 6).Value = P(L)
Worksheets("sheet2").Cells(L + 1 + 14 * (E - 9), 7).Value = N(L)
End If
Next
Dim FP As Integer
Dim Sum As Integer
Sum = 0
'수량*단가 구하기
For FP = (6 + 14 * (E - 9)) To (10 + 14 * (E - 9))
Worksheets("sheet2").Cells(FP, 4).Value = Worksheets("sheet2").Cells(FP, 2).Value * Worksheets("sheet2").Cells(FP, 3).Value
Worksheets("sheet2").Cells(FP, 8).Value = Worksheets("sheet2").Cells(FP, 6).Value * Worksheets("sheet2").Cells(FP, 7).Value
'총액 구하기
Sum = Sum + Worksheets("sheet2").Cells(FP, 4).Value + Worksheets("sheet2").Cells(FP, 8).Value
'0 지우기
If Worksheets("sheet2").Cells(FP, 4).Value = 0 Then
Worksheets("sheet2").Cells(FP, 4).ClearContents
End If
If Worksheets("sheet2").Cells(FP, 8).Value = 0 Then
Worksheets("sheet2").Cells(FP, 8).ClearContents
End If
Next
'총액 구하기2
Worksheets("sheet2").Cells(12 + 14 * (E - 9), 8).Value = Sum
'받으실 분
Worksheets("sheet2").Cells(3 + 14 * (E - 9), 2).Value = Worksheets("0618").Cells(E, 3).Value
'주소
Worksheets("sheet2").Cells(3 + 14 * (E - 9), 5).Value = Worksheets("0618").Cells(E, 2).Value
'서식 복사'
Worksheets("sheet3").Range("A1:H13").Copy
Worksheets("sheet2").Range("A" & 15 + 14 * (E - 9)).PasteSpecial
If Index = 0 Then Exit Sub
Next
Debug.Print Join(V, vbLf)
End Sub
I expected this code to be like this
But the result is like this
When E = 9, the code runs exactly the same as I thought, but when E is over 10, it doesn't.
when E = 9, the V array's values and orders are like this [grape, apple], and that's what I wanted.
However, when E = 10, I want the V array's value to be like this [orange]
but the result says it is [ , , orange]
Could someone tell me what's wrong with my code?
For me, the two (different) pictures look like 'Chinese'... So, I cannot refer to them.
No need to use Index, Index2 and Index3. Use only Index and increment it at the second loop end;
'replace this line
Index_3 = Index_3 + 1
'with
Index = Index + 1
' and comment all the previous index incrementations
You must reinitialize the used arrays content and used Index at the first loop end:
'your code...
If Index = 0 Then Exit Sub 'after this existing code line
Erase V: Erase P: Erase N: Index = 0
Next
'Your code
Now, using Redim Preserve to often is bad from memory handling point of view. Please, try firstly ReDim to a value to exceed the necessary number of necessary elements (ReDim V(cCount)) and use only of the end: Redim Preserve V(Index -1). Do the same for the other two used arrays...

Case Statement, for loop and if...else in VBA

In the above column i have unique date.
I have a drop down list where anything can be selected.. so it has 8 permutation(2^3)..So i want to extract probable date based on the selection..Suppose if i select Year as 2020 and day as 19 then i will extract the probable date which match both the condition..Like above picture...
Right now i am using 8 if elseif-=...end if statment...and for loop..Is there any other way to do the same work?? I wanted to write a function which will take (day,month,year,lastrow) as parameter and based on probable date will be calculated..Can anyone give me any idea how to do it?
My code now:
Public Sub ProbableDate(CaseNo As Integer, lastrow As Long)
Dim sh As Worksheet, sh1 As Worksheet
Set sh1 = Worksheets("Dashboard")
Set sh = Worksheets("Logical operation")
Dim Y As String, M As String, D As String
Y = sh1.Cells(4, 1).Value
M = sh1.Cells(4, 2).Value
D = sh1.Cells(4, 3).Value
Dim L As Long, i As Long
L = 2
With sh
.Range("H2:H1048576").Clear
For i = 2 To lastrow
Select Case CaseNo
Case 1
If Year(.Cells(i, 2).Value) = Y Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case 2
If MonthName(Month(.Cells(i, 2).Value)) = M Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case 3
If Day(.Cells(i, 2).Value) = D Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case 4
If Year(.Cells(i, 2).Value) = Y And MonthName(Month(.Cells(i, 2).Value)) = M Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case 5
If Year(.Cells(i, 2).Value) = Y And Day(.Cells(i, 2).Value) = D Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case 6
If Day(.Cells(i, 2).Value) = D And MonthName(Month(.Cells(i, 2).Value)) = M Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case 7
If Day(.Cells(i, 2).Value) = D And MonthName(Month(.Cells(i, 2).Value)) = M And Year(.Cells(i, 2).Value) = Y Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case Else
MsgBox "Wrong Info"
End Select
Next i
End With
End Sub
You can simplify your code using a binary lookup table. Each CaseNo matches with a particular set of true/false outcomes for the day, month and year check. These are different to your original mapping, here is the new map:
CaseNo DMY
0 fail
1 D
2 M
3 DM
4 Y
5 D Y
6 MY
7 DMY
And the code:
With sh
.Range("H:H").Clear
For i = 2 To lastrow
OK = 0
If Day(.Cells(i, 2).Value) = D Then OK = OK + 1
If MonthName(Month(.Cells(i, 2).Value)) = M Then OK = OK + 2
If Year(.Cells(i, 2).Value) = Y Then OK = OK + 4
If OK = CaseNo Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
Else
MsgBox "Wrong Info"
End If
Next i
End With

Modify a VBA code to drag down sumifs to a large number of rows and columns

I have the below code in part of my excel vba that I need to amend but could do with some help understanding.
In cells T, W, and Z there is a sum if formula in row 2, this VBA replicates this formula down to the last row. I am trying to update the formula so that it does this for column T,W,Z,AC and AF
I've changed the 1-3 to 1-5 but it is debugging at the doc(ii) line.
Please could anyone help me up understand and update it.
Dim a, k, i As Long, ii As Long, t As Long, w(1 To 3), x, dic(1 To 3) As Object
With Range("k2", Range("k" & Rows.Count).End(xlUp))
k = .Value
a = .Columns(8).Resize(, 10).Value
End With
For i = 1 To 3
Set dic(i) = CreateObject("Scripting.Dictionary")
dic(i).CompareMode = 1
ReDim x(1 To UBound(a, 1), 1 To 1) As Double: w(i) = x
Next
For i = 1 To UBound(a, 1)
For ii = 1 To 3
dic(ii)(a(i, (ii - 1) * 3 + ii + 1)) = i
Next
Next
For i = 1 To UBound(a, 1)
For ii = 1 To 3
t = (ii - 1) * 3 + ii
If dic(ii).exists(a(i, t)) Then
x = w(ii)
x(dic(ii)(a(i, t)), 1) = x(dic(ii)(a(i, t)), 1) + k(i, 1)
w(ii) = x
End If
Next
Next
For i = 1 To 3
Cells(2, (i + 4) * 4).Resize(UBound(a, 1)).Value = w(i)
Next
End Sub

Coding Minesweeper in Excel VBA: Mines are overlapping in same cell

So I'm doing a Minesweeper game for a class and everything is going fine more or less, however I had encountered a problem. Sometimes the Mines are being places in the same cell. I.e.: If i have 10 bombs sometimes 9 bombs would be displayed.
Here is my Code so far:
Sub Minesweeper()
Dim Mines As Integer
Dim i As Integer
Dim j As Integer
Dim n As Integer
Dim m As Integer
Dim OverLap As Integer
'This is for Centering Text
For i = 8 To 15
For j = 6 To 13
Cells(i, j).HorizontalAlignment = xlCenter
Next j
Next i
'This is for setting Table/Board
For i = 8 To 15
For j = 6 To 13
'By default all cells will = 1 until bomb is placed
Cells(i, j).Value = 1
Next j
Next i
'This generates certain Number of Mines
For Mines = 1 To 10
Cells(((Int((15 - 8 + 1) * Rnd + 1)) + 7), ((Int((13 - 6 + 1) * Rnd + 1))) + 5).Value = 0
Next Mines
'This is for converting Mines to o and color change
For i = 8 To 15
For j = 6 To 13
If Cells(i, j).Value = 0 Then
Cells(i, j).Value = "o"
Cells(i, j).Font.Color = RGB(250, 0, 0)
ElseIf Cells(i, j).Value >= 1 Then
Cells(i, j).Font.Color = RGB(0, 0, 0)
End If
Next j
Next i
End Sub
Do an 'If' check of values during for Mines = 1 to 10. Declare your cell values first then check if that cell is a 1. If it is then place the 0. If it isn't then generate another random cell and recheck.
For Mines = 1 To 10
1
x = Int((15 - 8 + 1) * Rnd + 1) + 7
y = Int((13 - 6 + 1) * Rnd + 1) + 5
If Cells(x, y).Value = 1 Then
Cells(x, y).Value = 0
Else:
GoTo 1
End If
Next Mines

Trying to fix a Do While loop in VBA

thanks in advance for taking the time to help. I have built a Do While loop in VBA that for some reason breaks when j = 1. I have in cells C3:C7 these values: 13,14,14,13,14.
Here's the short script:
Dim i, j, n As Integer
Dim List(0) As Integer
i = o
j = 0
n = 0
Do While Cells(i + 3, 3) <> ""
If Cells(i + 3, 3) > 13 Then
List(j) = i + 3
j = j + 1
Cells(i + 3, 4) = "Noted"
i = i + 1
ElseIf Cells(i + 3, 3) = 13 Then
Cells(i + 3, 4) = "Skipped"
i = i + 1
Else
i = i + 1
End If
Loop
For n = j To n = 0
Rows(List(n)).Delete
Next
Thanks again!
Your intent is sound, but there are quite a few errors. See commented code below for details
Sub Demo()
' ~~ must explicitly type each variable. Use Long
Dim i As Long, j As Long, n As Long
Dim List() As Long '<~~ dynamic array
i = 3 '<~~ eliminate the klunky +3
j = 0
n = 0
ReDim List(0 To 0) '<~~ initialise dynamic array
Do While Cells(i, 3) <> vbNullString
If Cells(i, 3) > 13 Then
ReDim Preserve List(0 To j) '<~~ resize array
List(j) = i
j = j + 1
Cells(i, 4) = "Noted"
ElseIf Cells(i, 3) = 13 Then
Cells(i, 4) = "Skipped"
End If
i = i + 1 '<~~ simplify, its called in each if case anyway
Loop
' j will end up 1 greater than size of array
If j > 0 Then '<~~ only execute if we found some rows to delete
For n = j - 1 To 0 Step -1 '<~~ For loop syntax
Rows(List(n)).Delete
Next
End If
End Sub

Resources