ItIsHardToProgram
Technical User
Hey,
I have recently designed a macro in order to split a cell arithmetic into mutltiple cells. This is a quite simple concept, but I found the time it took to design this, what I would think, "simply" macro, was quite arsh, I put around 5 hours on this, and I realize that my lack of experience was probably the cause.
None the less, I am constantly trying to improve, so I will paste down the code. You will notice it gets "lazy" at some point. Yes I prety much got it to do the most time consuming, and figured I would do the rest manualy.
Please, feel free to help, I did not design the multiple char split, I burrowed it from open source documents and tweaked it so it would work with what I was trying to do. Oh and btw, it is the most ergonomic of the 2 functions D:
Now the followings don't behave badly, they currently work and take about 15 seconds. I am just looking to improve my way of thinking through programming, I think my worst enemy is the fact I constantly refuse to use arrays and cursors, it seems to be the fastest ><
Multiple char function
Split and write function (arrrggg)
"Knowing that you know is the greatest sign of stupidity, knowing that you are ignorant is the best proof of intelligence.
I have recently designed a macro in order to split a cell arithmetic into mutltiple cells. This is a quite simple concept, but I found the time it took to design this, what I would think, "simply" macro, was quite arsh, I put around 5 hours on this, and I realize that my lack of experience was probably the cause.
None the less, I am constantly trying to improve, so I will paste down the code. You will notice it gets "lazy" at some point. Yes I prety much got it to do the most time consuming, and figured I would do the rest manualy.
Please, feel free to help, I did not design the multiple char split, I burrowed it from open source documents and tweaked it so it would work with what I was trying to do. Oh and btw, it is the most ergonomic of the 2 functions D:
Now the followings don't behave badly, they currently work and take about 15 seconds. I am just looking to improve my way of thinking through programming, I think my worst enemy is the fact I constantly refuse to use arrays and cursors, it seems to be the fastest ><
Multiple char function
Code:
Function SplitMultiDelimsEX(Text As String, DelimStrings As String, _
DelimStringsSep As String) As String()
'''''''''''''''''''''''''''''''''''
' SplitMultiDelimsEX
' This function is like VBA's Split function or the SplitMultiDelims
' function, also in this module. It accepts any number of multiple-
' character delimiter strings and splits Text into substrings based
' on the delimiter strings. It returns an unallocated array if Text
' is empty, a single-element array if DelimStrings is empty, or a
' 1 or greater element array if Text was successfully split into
' substrings based on the DelimStrings delimiters.
'''''''''''''''''''''''''''''''''''
Dim Pos1 As Long
Dim N As Long
Dim M As Long
Dim Arr() As String
Dim I As Long
Dim DelimWords() As String
Dim DelimNdx As Long
Dim DelimWord As String
Dim bnegative As Boolean
'''''''''''''''
' if Text is empty, get out
'''''''''''''''
If Len(Text) = 0 Then
Exit Function
End If
''''''''''''''''''''''''''
' if there are no delimiters, return the whole text
''''''''''''''''''''''''''
If DelimStrings = vbNullString Then
SplitMultiDelimsEX = Array(Text)
Exit Function
End If
'''''''''''''''''''''
' if there is no delim separator, get out
'''''''''''''''''''''
If DelimStringsSep = vbNullString Then
Exit Function
End If
DelimWords = Split(DelimStrings, DelimStringsSep)
'If IsArrayAllocated(DelimWords) = False Then
' Exit Function
'End If
''''''''''''''''''''''''
' oversize the array, we'll shrink it later so
' we don't need to use Redim Preserve
''''''''''''''''''''''''
ReDim Arr(1 To Len(Text))
I = 0
N = 0
Pos1 = 1
For N = Pos1 To Len(Text)
For DelimNdx = LBound(DelimWords) To UBound(DelimWords)
DelimWord = DelimWords(DelimNdx)
Select Case DelimWord
Case "="
If StrComp(Mid(Text, N, Len(DelimWord)), DelimWord, vbBinaryCompare) = 0 Then
I = I + 1
If bnegative = True Then
Arr(I) = "-" + Mid(Text, Pos1, N - Pos1)
bnegative = False
Else
Arr(I) = Mid(Text, Pos1, N - Pos1)
End If
Pos1 = N + Len(DelimWord)
N = Pos1
End If
Case "+"
If StrComp(Mid(Text, N, Len(DelimWord)), DelimWord, vbBinaryCompare) = 0 Then
I = I + 1
If bnegative = True Then
Arr(I) = "-" + Mid(Text, Pos1, N - Pos1)
bnegative = False
Else
Arr(I) = Mid(Text, Pos1, N - Pos1)
End If
Pos1 = N + Len(DelimWord)
N = Pos1
End If
Case "-"
If StrComp(Mid(Text, N, Len(DelimWord)), DelimWord, vbBinaryCompare) = 0 Then
I = I + 1
If bnegative = True Then
Arr(I) = "-" + Mid(Text, Pos1, N - Pos1)
bnegative = False
Else
Arr(I) = Mid(Text, Pos1, N - Pos1)
End If
Pos1 = N + Len(DelimWord)
N = Pos1
bnegative = True
End If
End Select
Next DelimNdx
Next N
If Pos1 <= Len(Text) Then
I = I + 1
If bnegative = True Then
Arr(I) = "-" + Mid(Text, Pos1, N - Pos1)
bnegative = False
Else
Arr(I) = Mid(Text, Pos1, N - Pos1)
End If
End If
''''''''''''''''''
' chop off unused array elements
''''''''''''''''''
ReDim Preserve Arr(1 To I)
SplitMultiDelimsEX = Arr
End Function
Split and write function (arrrggg)
Code:
Private Sub Analyse700()
''''''''''''''''''''''''''''''''''''
' Cette fonction a été développé par Julien-Bono Roy '
' Toute utilisation de cette fonction doit être préapprouvée,de plus '
' si vous tentez d'utiliser cette fonction sans une compréhension de '
' vba, il y a de forte chance que les résultats ne soient pas adéquat '
' Cette fonction sépare et explose les cellules afin d'analyser leur '
' contenue. '
''''''''''''''''''''''''''''''''''''
Dim I As Integer, j As Integer, z As Integer
Dim x As Integer, y As Integer
Dim dValeurPlac As Double
Dim strBidon As String
Dim iWorksheet As Integer, strWorksheet As String
Dim strDecCell As String
Dim iacc As Integer
Dim varCellDec() As String
Dim VarCellAgregate() As String
Dim VarCellExplode() As String
Dim VarCellRAnge() As String
Dim VarCellRAnge2() As String
Dim SpreadRAnge As Integer
Dim bidon() As String
Dim startRange As Integer
Dim trash() As String
Dim bPositif As Boolean
Dim bnegative As Boolean
Dim bExitFor As Boolean
Dim bBidon As Boolean
For z = 1 To 10000
'Attribution de la feuille de travail 700
iWorksheet = ActiveWorkbook.ActiveSheet.Cells(z, 3).Value
strWorksheet = ActiveWorkbook.ActiveSheet.Name
If iWorksheet >= 701 And iWorksheet < 800 Then
strDecCell = ActiveWorkbook.Worksheets(strWorksheet).Cells(z, 5).Formula
If strDecCell = "" Then
z = z + 1
End If
VarCellAgregate = SplitMultiDelimsEX(strDecCell, "=,+,-", ",")
'For x = 1 To UBound(VarCellAgregate)
'Debug.Print (VarCellAgregate(x))
'Next x
For x = 1 To UBound(VarCellAgregate)
If UCase(Left(VarCellAgregate(x), 6)) = "SOMME(" Then
VarCellAgregate(x) = Right(VarCellAgregate(x), Len(VarCellAgregate(x)) - 6)
For j = x To UBound(VarCellAgregate)
If Right(VarCellAgregate(j), 1) = ")" Then
VarCellAgregate(j) = Left(VarCellAgregate(j), Len(VarCellAgregate(j)) - 1)
Exit For
End If
Next j
ElseIf UCase(Left(VarCellAgregate(x), 2)) = "-(" Then
VarCellAgregate(x) = "-" + Right(VarCellAgregate(x), Len(VarCellAgregate(x)) - 2)
iacc = x
For j = x To UBound(VarCellAgregate)
If Right(VarCellAgregate(j), 1) = ")" Then
VarCellAgregate(j) = Left(VarCellAgregate(j), Len(VarCellAgregate(j)) - 1)
Exit For
End If
iacc = iacc + 1
Next j
For I = x To iacc
If VarCellAgregate(I) = VarCellAgregate(x) Then
I = I + 1
End If
If Left(VarCellAgregate(I), 1) = "-" Then
VarCellAgregate(I) = Right(VarCellAgregate(I), Len(VarCellAgregate(I)) - 1)
Else
VarCellAgregate(I) = "-" + VarCellAgregate(I)
End If
Next I
ElseIf UCase(Left(VarCellAgregate(x), 7)) = "-SOMME(" Then
VarCellAgregate(x) = Right(VarCellAgregate(x), Len(VarCellAgregate(x)) - 7)
iacc = x
For j = x To UBound(VarCellAgregate)
If Right(VarCellAgregate(j), 1) = ")" Then
VarCellAgregate(j) = Left(VarCellAgregate(j), Len(VarCellAgregate(j)) - 1)
Exit For
End If
iacc = iacc + 1
Next j
For I = x To iacc
If VarCellAgregate(I) = VarCellAgregate(x) Then
VarCellAgregate(I) = "-" & VarCellAgregate(I)
ElseIf Left(VarCellAgregate(I), 1) = "-" Then
VarCellAgregate(I) = Right(VarCellAgregate(I), Len(VarCellAgregate(I)) - 1)
Else
VarCellAgregate(I) = "-" + VarCellAgregate(I)
End If
Next I
ElseIf UCase(Left(VarCellAgregate(x), 5)) = "-SUM(" Then
VarCellAgregate(x) = Right(VarCellAgregate(x), Len(VarCellAgregate(x)) - 5)
iacc = x
For j = x To UBound(VarCellAgregate)
If Right(VarCellAgregate(j), 1) = ")" Then
VarCellAgregate(j) = Left(VarCellAgregate(j), Len(VarCellAgregate(j)) - 1)
Exit For
End If
Next j
For I = x To iacc
If VarCellAgregate(I) = VarCellAgregate(x) Then
VarCellAgregate(I) = "-" & VarCellAgregate(I)
ElseIf Left(VarCellAgregate(I), 1) = "-" Then
VarCellAgregate(I) = Right(VarCellAgregate(I), Len(VarCellAgregate(I)) - 1)
ElseIf Left(VarCellAgregate(I), 1) = "--" Then
VarCellAgregate(I) = Right(VarCellAgregate(I), Len(VarCellAgregate(I)) - 1)
Else
VarCellAgregate(I) = "-" + VarCellAgregate(I)
'Debug.Print (VarCellAgregate(I))
End If
Next I
ElseIf UCase(Left(VarCellAgregate(x), 4)) = "SUM(" Then
VarCellAgregate(x) = Right(VarCellAgregate(x), Len(VarCellAgregate(x)) - 4)
For j = x To UBound(VarCellAgregate)
If Right(VarCellAgregate(j), 1) = ")" Then
VarCellAgregate(j) = Left(VarCellAgregate(j), Len(VarCellAgregate(j)) - 1)
Exit For
End If
Next j
End If
Next x
For y = 1 To UBound(VarCellAgregate)
VarCellExplode = Split(VarCellAgregate(y), ":")
If UBound(VarCellExplode) = -1 Or UBound(VarCellExplode) = 0 Then
y = y + 1
Else
VarCellAgregate(y) = ""
VarCellRAnge = Split(VarCellExplode(0), "E")
VarCellRAnge2 = Split(VarCellExplode(1), "E")
If bBidon = True Then
startRange = SpreadRAnge + 1
SpreadRAnge = startRange + Val(VarCellRAnge2(1)) - Val(VarCellRAnge(1))
Else
startRange = 0
SpreadRAnge = Val(VarCellRAnge2(1)) - Val(VarCellRAnge(1))
End If
End If
For x = 0 + startRange To SpreadRAnge
If UBound(VarCellExplode) = -1 Or UBound(VarCellExplode) = 0 Then
x = x + 1
Else
ReDim Preserve bidon(0 To SpreadRAnge) As String
bBidon = True
bidon(x) = Left(VarCellExplode(0), Len(VarCellExplode(0)) - Len(VarCellRAnge(1))) & CStr(Val(VarCellRAnge(1)) + x - startRange)
End If
Next x
'bidon(x) = String(val(
Next y
'Debug.Print (" " & z)
'For y = 0 To UBound(bidon)
' Debug.Print (bidon(y))
'Next y
Sheets.Add.Name = iWorksheet
With ActiveWorkbook.Worksheets(CStr(iWorksheet))
.Cells(1, 3).Value = iWorksheet
.Cells(2, 3).Formula = "=INFO!B1"
.Cells(3, 3).Value = ActiveWorkbook.Worksheets(strWorksheet).Cells(z, 1).Value + ActiveWorkbook.Worksheets(strWorksheet).Cells(z, 2).Value
.Cells(7, 4).Formula = "=INFO!C8"
.Cells(7, 6).Formula = "=INFO!E8"
.Cells(7, 8).Value = "Variations"
.Cells(7, 9).Formula = "%"
End With
If bBidon = True Then
For y = 0 To UBound(bidon)
Do Until bidon(y) <> "" And bidon(y) <> "+" And bidon(y) <> "-"
If UBound(bidon) = y Then
bExitFor = True
Exit Do
Else
y = y + 1
End If
Loop
If bExitFor = True Then
bExitFor = False
Exit For
End If
ActiveWorkbook.Worksheets(CStr(iWorksheet)).Cells(y + 13, 4).Formula = "=" & bidon(y)
trash = Split(bidon(y), "!")
If Left(bidon(y), 1) = "-" Then
ActiveWorkbook.Worksheets(CStr(iWorksheet)).Cells(y + 13, 1).Formula = "=" & Right(trash(0), Len(trash(0)) - 1) + "!" + "A" + Right(trash(1), Len(trash(1)) - 1)
ActiveWorkbook.Worksheets(CStr(iWorksheet)).Cells(y + 13, 2).Formula = "=" & Right(trash(0), Len(trash(0)) - 1) + "!" + "B" + Right(trash(1), Len(trash(1)) - 1)
Else
ActiveWorkbook.Worksheets(CStr(iWorksheet)).Cells(y + 13, 1).Formula = "=" & trash(0) + "!" + "A" + Right(trash(1), Len(trash(1)) - 1)
ActiveWorkbook.Worksheets(CStr(iWorksheet)).Cells(y + 13, 2).Formula = "=" & trash(0) + "!" + "B" + Right(trash(1), Len(trash(1)) - 1)
End If
Next y
End If
For y = 1 To UBound(VarCellAgregate)
Do Until VarCellAgregate(y) <> "" And VarCellAgregate(y) <> "+" And VarCellAgregate(y) <> "-"
If UBound(VarCellAgregate) = y Then
bExitFor = True
Exit Do
Else
y = y + 1
End If
Loop
If bExitFor = True Then
bExitFor = False
Exit For
End If
ActiveWorkbook.Worksheets(CStr(iWorksheet)).Cells(y + 13 + UBound(bidon), 4).Formula = "=" & VarCellAgregate(y)
trash = Split(VarCellAgregate(y), "!")
If Left(VarCellAgregate(y), 1) = "-" Then
ActiveWorkbook.Worksheets(CStr(iWorksheet)).Cells(y + 13 + UBound(bidon), 1).Formula = "=" & Right(trash(0), Len(trash(0)) - 1) + "!" + "A" + Right(trash(1), Len(trash(1)) - 1)
ActiveWorkbook.Worksheets(CStr(iWorksheet)).Cells(y + 13 + UBound(bidon), 2).Formula = "=" & Right(trash(0), Len(trash(0)) - 1) + "!" + "B" + Right(trash(1), Len(trash(1)) - 1)
Else
ActiveWorkbook.Worksheets(CStr(iWorksheet)).Cells(y + 13 + UBound(bidon), 1).Formula = "=" & trash(0) + "!" + "A" + Right(trash(1), Len(trash(1)) - 1)
ActiveWorkbook.Worksheets(CStr(iWorksheet)).Cells(y + 13 + UBound(bidon), 2).Formula = "=" & trash(0) + "!" + "B" + Right(trash(1), Len(trash(1)) - 1)
End If
Next y
'For y = 1 To UBound(VarCellAgregate)
' Debug.Print (VarCellAgregate(y))
'Next y
End If
ActiveWorkbook.Worksheets(strWorksheet).Activate
ReDim Preserve bidon(0) As String
bBidon = False
Next z
MsgBox ("Macro terminé, assurez-vous de bien concilier les placements pour qu'il n'y ait pas d'erreur")
'Julien-Bono Roy, 2011, les montants doivent être conciliés suite à l'exécution de la macro
End Sub
"Knowing that you know is the greatest sign of stupidity, knowing that you are ignorant is the best proof of intelligence.