Hey I have the following test in my excel spreadsheet. I'm trying to be able to read the range as an array.
Period CAt1 Cat2 Cat3 Cat4
0 A B C D
1 E F g h
2 l k d i
3 m B dsfasd D
4 n a C D
5 o B fs D
6 p B C D
7 q B df D
8 r B fas D
9 s B fad D
10 Test Deal B dsfasd D
11 u B C D
I've made a range name for this call Check. I'm trying the following code, it works for a 2-d array. I want it to work on an abstract number based on the range name. I've tried adjusting it to work. The idea is that I want to call the row so that my udt can be able to read at a Period the Category value.
So in my main():
Sub Tst()
Dim Temp As Variant
Temp = Check("Initialise")
Debug.Print Check("0")
End Sub
Function Check(getItem As String)
Static CapitalFactors(362, 2)
Static Counter As Integer
Dim cell As Variant
Dim I As Integer
Dim j As Integer
Dim exitflag As Boolean
Dim Response As Integer
Dim Wsheet As String
Dim TopRow As Integer
Dim LeftCol As Integer
exitflag = False
If getItem = "Initialise" Then
I = 1
j = 1
For Each cell In Range("Check")
CapitalFactors(I, j) = cell
j = j + 1
If j > 2 Then
j = 1
I = I + 1
End If
Next
'Range("InputMonitor").ClearContents
Counter = 0
Else
I = 0
Do Until I = UBound(CapitalFactors, 1) Or exitflag = True
I = I + 1
If UCase(CapitalFactors(I, 1)) = UCase(getItem) Then
Check = CapitalFactors(I, 2)
exitflag = True
'If CapitalFactors(I,[Customized CashFlow Flag] = "No" Then Debug.Print 1 'GoSub SheetHighlight
End If
Loop
If exitflag = False Then Response = MsgBox("Parameter -" & getItem & "- not found", vbCritical)
End If
End Function
Related
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
I have a date (2/1/2018)in D1 cell and now I want to increase date by one in all cells from D2 to AH using VBA
Any suggestion ?
THanks
Sree
Please note that if variable data type is set as Date it will increasing day of date when summing with 1.
VBA:
Sub DateIncreaser
Dim d as Date
d = Selection.value 'Assign appropriated value to d variable.
d = d + 1
debug.print d 'This optional line shows the result in immediate window.
Range("D2").Value = d
End Sub
Update1
Sub DateIncreaser()
Dim d As Date
Dim i As Integer
Dim InitialColumnIndex As Integer
Dim FinalColumnIndex As Integer
Dim RowsIndex As Long
InitialColumnIndex = 1
FinalColumnIndex = 34 'Representative AH Column
RowsIndex = 2
d = Selection.Value 'Source date value
For i = InitialColumnIndex To FinalColumnIndex
d = d + 1
Cells(RowsIndex, i).Value = d
Next i
End Sub
Update2
Sub DateIncreaser()
Dim d As Date
Dim i, j As Integer
Dim InitialColumnIndex As Integer
Dim FinalColumnIndex As Integer
Dim RowsIndex As Long
InitialColumnIndex = 1
FinalColumnIndex = 34 'Representative AH Column
RowsIndex = 2
For j = 1 To Sheets.Count
d = Range("D1").Value 'Source date value
For i = InitialColumnIndex To FinalColumnIndex
d = d + 1
Worksheets(j).Cells(RowsIndex, i).Value = d
Next i
Next j
End Sub
I was wondering why the following syntax does not work the way I thought it would in VBA, and what I should do to ensure it does;
For a = 1 To 10
For b = 1 To 10
For c = 1 To 10
If a <> b <> c Then
MsgBox (a & " " & b & " " & c)
End If
Next c
Next b
Next a
This is a simplified example, which can still be manually obtained with:
if a<>b and b<>c and c<>a then
But my actual intended code has 10 such variables multiple times, which makes it unfeasible with 55 unequal conditions, or likely for me to make a typo. I think there is a more efficient way but I have not found it.
Ps. My goal is to only have a message box pop up if all the variables are unique.
I have obtained my goal, though it can probably be done much more efficient than:
For a = 1 To 10
check(a) = True
For b = 1 To 10
If check(b) = False Then
check(b) = True
For c = 1 To 10
If check(c) = False Then
check(c) = True
For d = 1 To 10
If check(d) = False Then
check(d) = True
For e = 1 To 10
If check(e) = False Then
check(e) = True
MsgBox (a & " " & b & " " & c & " " & d & " " & e)
End If
check(e) = False
check(a) = True
check(b) = True
check(c) = True
check(d) = True
Next e
End If
check(d) = False
check(a) = True
check(b) = True
check(c) = True
Next d
End If
check(c) = False
check(a) = True
check(b) = True
Next c
End If
check(b) = False
check(a) = True
Next b
Next a
Here is an implementation of the Johnson-Trotter algorithm for enumerating permutations. It is a small modification of one that I wrote once when playing around with brute-force solutions to the Traveling Salesman Problem. Note that it returns a 2-dimensional array, which might consume a lot of memory. It is possible to refactor it so that it is a sub where the permutations are consumed rather than stored. Just replace the part of the code near the bottom (where the current permutation, perm, is stored in the array perms) by the code that uses the permutation.
Function Permutations(n As Long) As Variant
'implements Johnson-Trotter algorithm for
'listing permutations. Returns results as a variant array
'Thus not feasible for n > 10 or so
Dim perm As Variant, perms As Variant
Dim i As Long, j As Long, k As Long, r As Long, D As Long, m As Long
Dim p_i As Long, p_j As Long
Dim state As Variant
m = Application.WorksheetFunction.Fact(n)
ReDim perm(1 To n)
ReDim perms(1 To m, 1 To n) As Integer
ReDim state(1 To n, 1 To 2) 'state(i,1) = where item i is currently in perm
'state(i,2) = direction of i
k = 1 'will point to current permutation
For i = 1 To n
perm(i) = i
perms(k, i) = i
state(i, 1) = i
state(i, 2) = -1
Next i
state(1, 2) = 0
i = n 'from here on out, i will denote the largest moving
'will be 0 at the end
Do While i > 0
D = state(i, 2)
'swap
p_i = state(i, 1)
p_j = p_i + D
j = perm(p_j)
perm(p_i) = j
state(i, 1) = p_j
perm(p_j) = i
state(j, 1) = p_i
p_i = p_j
If p_i = 1 Or p_i = n Then
state(i, 2) = 0
Else
p_j = p_i + D
If perm(p_j) > i Then state(i, 2) = 0
End If
For j = i + 1 To n
If state(j, 1) < p_i Then
state(j, 2) = 1
Else
state(j, 2) = -1
End If
Next j
'now find i for next pass through loop
If i < n Then
i = n
Else
i = 0
For j = 1 To n
If state(j, 2) <> 0 And j > i Then i = j
Next j
End If
'record perm in perms:
k = k + 1
For r = 1 To n
perms(k, r) = perm(r)
Next r
Loop
Permutations = perms
End Function
Tested like:
Sub test()
Range("A1:G5040").Value = Permutations(7)
Dim A As Variant, i As Long, s As String
A = Permutations(10)
For i = 1 To 10
s = s & " " & A(3628800, i)
Next i
Debug.Print s
End Sub
The first 20 rows of output look like:
Also, 2 1 3 4 5 6 7 8 9 10 is printed in the immediate window. My first version used a vanilla variant away and caused an out-of-memory error with n = 10. I tweaked it so that perms is redimensioned to contain integers (which consume less memory than variants) and is now able to handle 10. It takes about 10 seconds on my machine to run the test code.
You could simply add a check right after the beginning of each inner loop, like follows
For a = 1 To 10
For b = 1 To 10
If b <> a Then '<-- this check will make sure subsequent inner loops shouldn't bother but for their loops variables
For c = 1 To 10
If c <> b Then '<-- same comment as preceeding one
For d = 1 to 10
If d <> c then MsgBox (a & " " & b & " " & c & " " & d) '<-- last check for last two variables
Next d
End If
Next c
End If
Next b
Next a
Try putting all those variables into the array and checking the array for duplicates, if none found, display the message box. Something like this:
Sub dupfind()
Dim ArrHelper(2) As Long
Dim k As Long
Dim j As Long
Dim ans As Long
Dim dupl As Boolean
Dim ArrAnswers() As Long
ans = 0
For a = 1 To 10
ArrHelper(0) = a
For b = 2 To 10
ArrHelper(1) = b
For c = 1 To 10
ArrHelper(2) = c
dupl = False
For k = 0 To UBound(ArrHelper) - 1
For j = k + 1 To UBound(ArrHelper)
If ArrHelper(k) = ArrHelper(j) Then
dupl = True
End If
Next j
Next k
If dupl = False Then
ReDim Preserve ArrAnswers(3, ans)
ArrAnswers(0, ans) = a
ArrAnswers(1, ans) = b
ArrAnswers(2, ans) = c
ans = ans + 1
End If
Next c
Next b
Next a
End Sub
Read your edit regarding storing permutations and changed the code a bit
I've tried to create an array with 2 row and 5 columns in VBA codes. Is it possible? i wrote like this
Sub robin()
Cells.Select 'this codes clears previous entries
Range("T17").Activate
Selection.ClearContents
Range("E4").Select
Dim myArray(1, 4) As Double
Dim a As Double, b As Double
Dim i As Integer
Dim j As Integer
Dim c As Double
c = 1
For a = 0 To UBound(myArray())
For b = 0 To UBound(myArray())
myArray(a, b) = c
ThisWorkbook.Sheets("Sheet1").Cells(a + 1, b + 1).Value = myArray(a, b)
c = c + 1
Next b
Next a
End Sub
But it comes with two rows and two columns. What to do?
By default UBound will return the highest index of the first dimension of an array. You'll need to set the optional parameter to 2 to get the last index of the 2nd dimension.
For b = 0 To UBound(myArray(), 2)
Sub batman()
[Sheet1!A1:E2] = [{1,2,3,4,5;6,7,8,9,10}]
End Sub
or
Sub robin()
Dim myArray(1 To 2, 1 To 5) As Double, c As Long
For c = 1 To 5
myArray(1, c) = c
myArray(2, c) = c + 5
Next
[Sheet1!A1:E2] = myArray
End Sub
Thanks all of you for your time. I've figured out my way to get what I was looking for. I rewrote the code like this:
Sub robin()
Cells.Select 'this codes clears previous entries
Range("T17").Activate
Selection.ClearContents
Range("E4").Select
Dim myArray(1, 5) As Double
Dim a As Double, b As Double
Dim i As Integer
Dim j As Integer
Dim c As Double
c = 1
For a = LBound(myArray, 1) To UBound(myArray, 1)
For b = LBound(myArray, 2) To UBound(myArray, 2)
myArray(a, b) = c
ThisWorkbook.Sheets("Sheet1").Cells(a + 1, b + 1).Value = myArray(a, b)
c = c + 1
Next b
Next a
End Sub
And that worked perfect for me. Thanks again.
I am running a VBA script through a directory but I need to go through the files as if they were sorted in Windows Explorer. For example I have a directory like so:
32 Read.log
64 Write.log
256 Read.log
512 Write.log
1024 Write.log
4 Read.log
When I sort it with VBA, it only looks at the first character to sort it like so:
1024 Write.log
256 Read.log
32 Read.log
4 Read.log
512 Write.log
64 Write.log
Any ideas on how to sort from smallest to largest number before I go through the directory?
I actually went to the trouble of building an algorithm for it:
Dim a As Variant
Dim c As String
Dim d As String
Dim x As Long
Dim y As Long
Dim s As Boolean
Dim p As Long
Dim q As Long
Dim e As Long
Dim n1 As String
Dim n2 As String
'Create a dummy array to test
a = Array("1024 Write.log", "256 Read.log", "32 Read.log", "4 Read.log", "512 Write.log", "64 Write.log")
'Loop through the array and look for values that need to change position
For x = LBound(a) To UBound(a) - 1
For y = x + 1 To UBound(a)
'Check if the values at x and y must be swapped
s = False
'Loop through each character in both strings to do a compare
If Len(a(x)) > Len(a(y)) Then e = Len(a(x)) Else e = Len(a(y))
For p = 1 To e
If Len(a(x)) < p Then
'y is longer, so it should come last
Exit For
ElseIf Len(a(y)) < p Then
'y is shorter, so it should come first
s = True
Exit For
ElseIf InStr("0123456789", Mid(a(x), p, 1)) = 0 Or InStr("0123456789", Mid(a(y), p, 1)) = 0 Then
'The char at p in x or y is not a number, so do a text compare
If Mid(a(x), p, 1) < Mid(a(y), p, 1) Then
Exit For
ElseIf Mid(a(x), p, 1) > Mid(a(y), p, 1) Then
s = True
Exit For
End If
Else
'The char at p for both x and y are numbers, so get the whole numbers and compare
'Get the number for x
n1 = ""
q = p
Do While q <= Len(a(x)) And InStr("0123456789", Mid(a(x), q, 1)) <> 0
n1 = n1 & Mid(a(x), q, 1)
q = q + 1
Loop
'Get the number for y
n2 = ""
q = p
Do While q <= Len(a(y)) And InStr("0123456789", Mid(a(y), q, 1)) <> 0
n2 = n2 & Mid(a(y), q, 1)
q = q + 1
Loop
If Len(n1) > Len(n2) Then
'n1 is a bigger number, so it should be last
s = True
Exit For
ElseIf Len(n1) < Len(n2) Then
'n1 is smaller, so it should remain first
Exit For
ElseIf n1 > n2 Then
'n1 is a bigger number, so it should be last
s = True
Exit For
ElseIf n1 < n2 Then
'n1 is smaller, so it should remain first
Exit For
End If
End If
Next
'Do the swap
If s Then
c = a(y)
a(y) = a(x)
a(x) = c
End If
Next
Next
'Verify that it worked
c = ""
For p = LBound(a) To UBound(a)
c = c & a(p) & vbCrLf
Next
MsgBox c
Once the data has been imported into Excel, parse the data so the size is in column A and the name is in column B. Then insure (or convert) the data in column A to be values rather than Text. Then sort columns A & B by A Ascending.
Read the directory into a dictionary object as in CreateObject("Scripting.Dictionary") and write a function that will sort the dictionary in the exact way you want.
An example can be found at this question:
Sort dictionary
EDIT: If you already have it in an array, you can adjust the code to just sort the array
EDIT: Simple example of using a dictionary:
Dim vArray As Variant
Dim vDict As Object
Dim i As Variant
vArray = Array("F1", "F2", "F3")
Set vDict = CreateObject("Scripting.Dictionary")
For i = LBound(vArray) To UBound(vArray)
vDict.Add i, vArray(i)
Next
For Each i In vDict
MsgBox "Key: " & i & ", Value: " & vDict(i)
Next