Maybe I'm being too fussy, but my macro takes about 1 second to run in a powerfull laptop (with little data). But it will run on average-slow performance pc's.
Is there a way to optimize this code? Do you think Select Case is slowing down the execution? If so, how can I improve it?
Sorry for the extension of the code.
Thank you.
Private Sub crear_Click()
Dim ctrl As Control, ctrl2 As Control, aler As Variant, ws As Worksheet, ws2 As Worksheet, ultimafila As Double, ultimaFila2 As Double, i As Integer, pPage As MSForms.Page, N As Double, selectedItems As String, valorProbabilidad As Integer, valorImpacto As Integer, valorMagnitud As Integer, resta As Long, ultimaFila3 As Long, j As Long, ultimaFila4 As Long, k As Double, l As Double
Set ws = Worksheets("Valoración"): Set ws2 = Worksheets("lista_riesgos")
ultimafila = ws.ListObjects("Riesgos").Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
ultimaFila2 = ws2.ListObjects("consolidadoRiesgos").Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
ultimaFila3 = ws2.ListObjects("consolidadoRiesgos").Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1
ultimaFila4 = ws2.ListObjects("Riesgo").Range.Columns(2).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row - 1
resta = 0.5
With Me
For Each ctrl In .Controls
If Left(ctrl.Name, 5) = "texto" Then
If Trim(ctrl.Value & vbNullString) = vbNullString Then
aler = Replace(ctrl.Name, "texto", "alerta")
.Controls(aler).Visible = True
End If
ElseIf Left(ctrl.Name, 5) = "lista" Then
For N = 0 To listaObjetivos.ListCount - 1
If listaObjetivos.Selected(N) Then GoTo algoSeleccionado
Next N
aler = Replace(ctrl.Name, "lista", "alerta")
.Controls(aler).Visible = True
GoTo salir
algoSeleccionado:
aler = Replace(ctrl.Name, "lista", "alerta")
.Controls(aler).Visible = False
GoTo continuar
salir:
End If
Next ctrl
Exit Sub
End With
continuar:
Select Case Me.textoFrecuencia
Case "Casi seguro"
valorProbabilidad = 5
Case "Probable"
valorProbabilidad = 4
Case "Posible"
valorProbabilidad = 3
Case "Improbable"
valorProbabilidad = 2
Case "Raro"
valorProbabilidad = 1
End Select
Select Case Me.textoImpacto
Case "Catastrófico"
valorImpacto = 5
Case "Mayor"
valorImpacto = 4
Case "Moderado"
valorImpacto = 3
Case "Menor"
valorImpacto = 2
Case "Insignificante"
valorImpacto = 1
End Select
valorMagnitud = valorProbabilidad * valorImpacto
With ws
.Unprotect Password:="pAtRiCiA"
For Each ctrl In Me.Controls
If Left(ctrl.Name, 5) = "texto" Then
.Cells(ultimafila, ctrl.TabIndex) = ctrl.Value
End If
Next ctrl
For i = 0 To listaObjetivos.ListCount - 1
If listaObjetivos.Selected(i) = True Then
ws.Cells(ultimafila, (i) + 6) = "X"
'selectedItems = selectedItems & listaObjetivos.List(i) & (i) & vbNewLine
End If
Next i
Select Case valorMagnitud
Case Is >= 15
.Cells(ultimafila, 25) = "Extremo"
Case 8 To 14
.Cells(ultimafila, 25) = "Alto"
Case 4 To 7
.Cells(ultimafila, 25) = "Medio"
Case 1 To 3
.Cells(ultimafila, 25) = "Aceptable"
End Select
.Rows(ultimafila).AutoFit
.Rows(ultimafila).RowHeight = .Cells(ultimafila, 1).Height + 12
.Protect Password:="pAtRiCiA", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
With ws2
.Unprotect Password:="pAtRiCiA"
.Cells(ultimaFila2, 1) = (valorProbabilidad * valorProbabilidad * valorProbabilidad) + valorImpacto
.Cells(ultimaFila2, 2) = Me.textoCodigo
.ListObjects("Riesgo").DataBodyRange.Columns(1).ClearContents
For k = 1 To ultimaFila3
Select Case .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 1).Value
Case 2
If .ListObjects("Riesgo").DataBodyRange.Cells(1, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(1, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(1, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(1, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 3
If .ListObjects("Riesgo").DataBodyRange.Cells(2, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(2, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(2, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(2, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 4
If .ListObjects("Riesgo").DataBodyRange.Cells(3, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(3, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(3, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(3, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 5
If .ListObjects("Riesgo").DataBodyRange.Cells(4, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(4, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(4, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(4, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 6
If .ListObjects("Riesgo").DataBodyRange.Cells(5, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(5, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(5, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(5, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 9
If .ListObjects("Riesgo").DataBodyRange.Cells(6, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(6, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(6, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(6, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 10
If .ListObjects("Riesgo").DataBodyRange.Cells(7, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(7, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(7, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(7, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 11
If .ListObjects("Riesgo").DataBodyRange.Cells(8, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(8, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(8, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(8, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 12
If .ListObjects("Riesgo").DataBodyRange.Cells(9, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(9, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(9, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(9, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 13
If .ListObjects("Riesgo").DataBodyRange.Cells(10, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(10, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(10, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(10, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 28
If .ListObjects("Riesgo").DataBodyRange.Cells(11, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(11, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(11, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(11, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 29
If .ListObjects("Riesgo").DataBodyRange.Cells(12, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(12, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(12, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(12, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 30
If .ListObjects("Riesgo").DataBodyRange.Cells(13, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(13, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(13, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(13, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 31
If .ListObjects("Riesgo").DataBodyRange.Cells(14, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(14, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(14, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(14, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 32
If .ListObjects("Riesgo").DataBodyRange.Cells(15, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(15, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(15, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(15, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 65
If .ListObjects("Riesgo").DataBodyRange.Cells(16, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(16, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(16, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(16, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 66
If .ListObjects("Riesgo").DataBodyRange.Cells(17, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(17, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(17, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(17, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 67
If .ListObjects("Riesgo").DataBodyRange.Cells(18, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(18, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(18, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(18, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 68
If .ListObjects("Riesgo").DataBodyRange.Cells(19, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(19, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(19, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(19, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 69
If .ListObjects("Riesgo").DataBodyRange.Cells(20, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(20, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(20, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(20, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 126
If .ListObjects("Riesgo").DataBodyRange.Cells(21, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(21, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(21, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(21, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 127
If .ListObjects("Riesgo").DataBodyRange.Cells(22, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(22, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(22, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(22, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 128
If .ListObjects("Riesgo").DataBodyRange.Cells(23, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(23, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(23, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(23, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 129
If .ListObjects("Riesgo").DataBodyRange.Cells(24, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(24, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(24, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(24, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
Case 130
If .ListObjects("Riesgo").DataBodyRange.Cells(25, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(25, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(25, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(25, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(k + 1, 2)
End If
End Select
Next k
.Protect Password:="pAtRiCiA", DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
For j = 0 To listaObjetivos.ListCount - 1
listaObjetivos.Selected(j) = False
Next
Me.textoCodigo = Null
Me.textoTipo = Null
Me.textoResponsable = Null
Me.textoDescripcion = Null
Me.textoDetalle = Null
Me.textoControles = Null
Me.textoFrecuencia = Null
Me.textoEscala = Null
Me.textoImpacto = Null
End Sub
Your many Select Case statements would indeed eat up a lot of time. At a quick glance, there is a firm relationship between the Case and the result. The following example shows how you could compress all your Select statements in the K-loop into a single statement.
Dim R As Long
R = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(K + 1, 1).Value
If .ListObjects("Riesgo").DataBodyRange.Cells(1, 1) = Empty Then
.ListObjects("Riesgo").DataBodyRange.Cells(R - 1, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(K + 1, 2)
Else
.ListObjects("Riesgo").DataBodyRange.Cells(R - 1, 1) = .ListObjects("Riesgo").DataBodyRange.Cells(R - 1, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(K + 1, 2)
End If
Unfortunately, the relationship isn't always -1. Therefore I suggest that you declare an array before you enter the K-loop, like this:-
Dim Clm() As Variant
Clm = Array(2, 3, 4, 5, 6, 9, 10, 11, 12, 13, 28)
The numbers in the array are exactly your 'Case' conditions. You should extend this list up to 130 which is your last 'Case'. With the help of this tool you can now replace all the Case statements with just one:-
Dim Clm() As Variant ' Place your Dim statements
Dim C As Long, R As Long ' at the top of your code
Clm = Array(2, 3, 4, 5, 6, 9, 10, 11, 12, 13, 28)
' start the K-loop here
C = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(K + 1, 1).Value
R = Application.Match(C, Clm, 0)
With .ListObjects("Riesgo").DataBodyRange
If .Cells(1, 1) = Empty Then
.Cells(R, 1) = .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(K + 1, 2)
Else
.Cells(R, 1) = .Cells(R, 1) & " " & .ListObjects("consolidadoRiesgos").DataBodyRange.Cells(K + 1, 2)
End If
End With
An error will occur if a match isn't found. Match will return the number of the element in the array which, it so happens, is the row number you need. You could modify this if required. The point is that the Match function returns a consecutive number from a range of random numbers.
Related
New to stack here.
I'm on VBA and am creating a quoting tool where outputs are generated if certain cells are populated from row 57 onwards. I.e. "For a = 57 to 1000".
For each of row "a" that has values, I'm trying to have Cells(a + 1, 6) output the sum of the previous a columns.
It took some time to find how to reference a range using cells, but I've been stuck from there. To reference the range I've found something along the lines of below
With Sheet1
.Range(.Cells(a, 6), .Cells(a + 1, 6)).Value2 = "b"
End With
The .Range(.Cells(a, 7), .Cells(a + 1, 7)) are the cells that I want to create a sum for but I'm not sure how to do this (and whether the With Sheet1 and End With sections are needed.
Full VBA code here:
Sub OnEntry()
On Error Resume Next
For a = 14 To 1000
If IsEmpty(Cells(a, 3)) = False And IsEmpty(Cells(a, 4)) = True Then
If IsEmpty(Cells(a + 2, 4)) = True And IsEmpty(Cells(a + 3, 4)) = True And IsEmpty(Cells(a + 2, 3)) = True Then
GoTo GoHere
End If
If IsEmpty(Cells(a, 4)) = True And IsEmpty(Cells(a + 1, 4)) = False Then
GoTo GoHere
End If
Find = Range("'Sheet1'!$B$6:$B$5000").Find(Cells(a, 3).Value).Address
Row# = Range(Find).Row
Cells(a, 4) = Sheets("Sheet1").Cells(Row#, 3)
Cells(a, 5).Value = "=VLOOKUP(C" & a & ", 'Sheet1'!$B$6:$F$5000, 4, 0)"
Cells(a, 7).Value = "=B" & a & "*E" & a
If Cells(a - 1, 1) = "Line" Then
Cells(a, 1).Value = 1
Else
Cells(a, 1).Value = Cells(a - 1, 1) + 1
End If
Cells(a + 1, 1).EntireRow.Insert
**Stuck here**
With Sheet2
.Range(.Cells(a + 1, 7), .Cells(a + 2, 7)).Value2 = "b"
End With
End If
Next a
GoHere:
WaitTime = Now() + TimeValue("00:00:02")
While Now() < WaitTime
DoEvents
Wend
End Sub
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 2 years ago.
Improve this question
i have a problem and i do not know how to solve it.
i have to find a formula in excel or code in vba to highlights the 4 consecutive numbers from a cell B2.
In this cell are 20 numbers (from 1 to 90).
Tray this code, please:
Sub testSplitExtract()
Dim c As Range, arr As Variant, i As Long, boolFound As Boolean
Set c = Range("B2")
arr = Split(c.Value, ",") 'obtain the values array
arraySort arr 'sort the obtained array
For i = 0 To UBound(arr) - 3
If CLng(arr(i)) = CLng(arr(i + 1)) - 1 And _
CLng(arr(i + 1)) = CLng(arr(i + 2)) - 1 And _
CLng(arr(i + 2)) = CLng(arr(i + 3)) - 1 Then
Debug.Print arr(i), arr(i + 1), arr(i + 2), arr(i + 3)
MsgBox arr(i) & "," & arr(i + 1) & "," & arr(i + 2) & "," & arr(i + 3)
boolFound = True: Exit For
End If
Next
If Not boolFound Then MsgBox "No four consecutive numbers in the analized cell"
End Sub
Private Function arraySort(ByRef arrS As Variant) ' function to sort the array
Dim i As Long, j As Long, str1 As Variant, str2 As Variant
For i = 0 To UBound(arrS)
For j = i To UBound(arrS)
If arrS(j) < arrS(i) Then
str1 = arrS(i)
str2 = arrS(j)
arrS(i) = str2
arrS(j) = str1
End If
Next j
Next i
End Function
You could use something like so as discussed above
Function CONSECUTIVE_NUMBERS(strInput As String) As Boolean
Dim a() As String
Dim l As Long
a = Split(strInput, ",")
For l = 0 To UBound(a) - 3
If (Trim(a(l + 1)) - Trim(a(l)) = 1) And _
(Trim(a(l + 2)) - Trim(a(l + 1)) = 1) And _
(Trim(a(l + 3)) - Trim(a(l + 2)) = 1) Then
CONSECUTIVE_NUMBERS = True
Exit For
End If
Next l
End Function
or changing the IF to be
If (Trim(a(l + 1)) - Trim(a(l)) = 1) And _
(Trim(a(l + 2)) - Trim(a(l + 1)) = 1) And _
(Trim(a(l + 3)) - Trim(a(l + 2)) = 1) Then
CONSECUTIVE_NUMBERS = Trim(a(l)) & "," & _
Trim(a(l + 1)) & "," & _
Trim(a(l + 2)) & "," & _
Trim(a(l + 3))
Exit For
End If
and having the a string return from the function to output the 4
Function ConsecutiveFour(myNumbers)
Dim Num, Result
Num = Split(myNumbers, ",")
For i = 0 To UBound(Num) - 3
If WorksheetFunction.And(Num(i + 1) - Num(i) = 1, Num(i + 2) - Num(i + 1) = 1, Num(i + 3) - Num(i + 2) = 1) = True Then
Result = Result & "," & "[" & Num(i) & "," & Num(i + 1) & "," & Num(i + 2) & "," & Num(i + 3) & "]"
End If
Next
ConsecutiveFour = Right(Result, Len(Result) - 1)
End Function
The code below searches and compares the file names between two folders (including subfolders) reporting how many duplicates there are between folders. Subfolder names are identical.
I need to prohibit to comare files from different subfolders. I mean macro should only compare files in subfolders with the same subfolder names even if in other folders there are files with the same file names.
Can anyone help?
Example:
**folder1** **folder2**
first_folder vs first_folder
1.xml 1.xml
2.xml 2.xml
second_folder vs second_folder
1.xml 1.xml
The macro should not search for and compare 1.xml file between first_folder and second_folder. Only files from the same folder name should be compared.
Thank you in advance.
Sub CompareContentsofTwoFolders()
Dim fcount As Variant
Dim pth1 As String, pth2 As String
Dim r1 As Single, r2 As Single
Dim arrd() As Variant
Dim arru() As Variant
ReDim arrd(0 To 5, 0)
ReDim arru(0 To 2, 0)
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
pth1 = .SelectedItems(1) & "\"
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
pth2 = .SelectedItems(1) & "\"
End With
Sheets.Add
Set x = ActiveSheet
Application.ScreenUpdating = False
x.Range("A1") = "Duplicate files"
x.Range("A2") = "Path"
x.Range("B2") = "File name"
x.Range("C2") = "Size"
x.Range("D2") = "Path"
x.Range("E2") = "File name"
x.Range("F2") = "Size"
x.Range("A:F").Font.Bold = False
x.Range("A1:F2").Font.Bold = True
Recursive pth1
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
x.Range("A2:C" & Lrow).Sort Key1:=x.Range("B1"), Header:=xlYes
arr1 = x.Range("A3:C" & Lrow).Value
x.Range("A3:C" & Lrow).Clear
Recursive pth2
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
x.Range("A2:C" & Lrow).Sort Key1:=x.Range("B1"), Header:=xlYes
arr2 = x.Range("A3:C" & Lrow).Value
x.Range("A3:C" & Lrow).Clear
x.Range("H1") = "Total number of files in Folder 1: " 'Modified No.1
x.Range("I1") = UBound(arr1, 1)
x.Range("H2") = "Total number of files in Folder 2: " 'Modified No.2
x.Range("I2") = UBound(arr2, 1)
For r1 = LBound(arr1, 1) To UBound(arr1, 1)
chk = False
If r1 > 1 Then
If arr1(r1, 2) = arr1(r1 - 1, 2) Then
For r3 = UBound(arrd, 2) To LBound(arrd, 2) Step -1
If arrd(2, r3) <> "" And arrd(1, r3) <> arr1(r1, 2) Then Exit For
If arrd(1, r3) = arr1(r1, 2) Then
If r3 = UBound(arrd, 2) Then ReDim Preserve arrd(UBound(arrd, 1), UBound(arrd, 2) + 1)
arrd(0, r3 + 1) = arr1(r1, 1)
arrd(1, r3 + 1) = arr1(r1, 2)
arrd(2, r3 + 1) = arr1(r1, 3)
ReDim Preserve arrd(UBound(arrd, 1), UBound(arrd, 2) + 1)
Exit For
End If
Next r3
For r3 = UBound(arru, 2) To LBound(arru, 2) Step -1
If arru(2, r3) <> "" And arru(1, r3) <> arr1(r1, 2) Then Exit For
If arru(1, r3) = arr1(r1, 2) Then
If r3 = UBound(arru, 2) Then ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
arru(0, r3 + 1) = arr1(r1, 1)
arru(1, r3 + 1) = arr1(r1, 2)
arru(2, r3 + 1) = arr1(r1, 3)
ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
Exit For
End If
Next r3
GoTo jmp
End If
End If
For r2 = LBound(arr2, 1) To UBound(arr2, 1)
If arr2(r2, 2) = arr1(r1, 2) Then
If chk = False Then
arrd(0, UBound(arrd, 2)) = arr1(r1, 1)
arrd(1, UBound(arrd, 2)) = arr1(r1, 2)
arrd(2, UBound(arrd, 2)) = arr1(r1, 3)
Else
arrd(0, UBound(arrd, 2)) = ""
arrd(1, UBound(arrd, 2)) = ""
arrd(2, UBound(arrd, 2)) = ""
End If
arrd(3, UBound(arrd, 2)) = arr2(r2, 1)
arrd(4, UBound(arrd, 2)) = arr2(r2, 2)
arrd(5, UBound(arrd, 2)) = arr2(r2, 3)
arr2(r2, 1) = ""
ReDim Preserve arrd(UBound(arrd, 1), UBound(arrd, 2) + 1)
chk = True
End If
Next r2
If chk = False Then
arru(0, UBound(arru, 2)) = arr1(r1, 1)
arru(1, UBound(arru, 2)) = arr1(r1, 2)
arru(2, UBound(arru, 2)) = arr1(r1, 3)
ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
End If
jmp:
Next r1
For r2 = LBound(arr2, 1) To UBound(arr2, 1)
If arr2(r2, 1) <> "" Then
arru(0, UBound(arru, 2)) = arr2(r2, 1)
arru(1, UBound(arru, 2)) = arr2(r2, 2)
arru(2, UBound(arru, 2)) = arr2(r2, 3)
ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
End If
Next r2
x.Range("A3").Resize(UBound(arrd, 2) + 1, UBound(arrd, 1) + 1) = Application.Transpose(arrd)
x.Range("H3") = "Total number of duplicate files: " 'Modified No.3
x.Range("I3") = UBound(arrd, 2)
x.Range("H4") = "Total number of unique files: " 'Modified No.4
x.Range("I4") = UBound(arru, 2)
x.Range("A" & UBound(arrd, 2) + 3) = "Unique files"
x.Range("A" & UBound(arrd, 2) + 4) = "Path"
x.Range("B" & UBound(arrd, 2) + 4) = "File name"
x.Range("C" & UBound(arrd, 2) + 4) = "Size"
x.Range("A" & UBound(arrd, 2) + 3 & ":C" & UBound(arrd, 2) + 4).Font.Bold = True
x.Range("A" & UBound(arrd, 2) + 5).Resize(UBound(arru, 2) + 1, UBound(arru, 1) + 1) = Application.Transpose(arru)
Application.ScreenUpdating = True
End Sub
Sub Recursive(FolderPath As String)
Dim Value As String, Folders() As String
Dim Folder As Variant, a As Long
ReDim Folders(0)
If Right(FolderPath, 2) = "\\" Then Exit Sub
Value = Dir(FolderPath, &H1F)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(FolderPath & Value) = 16 Or GetAttr(FolderPath & Value) = 48 Then
Folders(UBound(Folders)) = Value
ReDim Preserve Folders(UBound(Folders) + 1)
Else
If Right(Value, 4) = ".xml" Then
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
ActiveSheet.Range("A" & Lrow) = FolderPath
ActiveSheet.Range("B" & Lrow) = Value
ActiveSheet.Range("C" & Lrow) = FileLen(FolderPath & Value)
End If
End If
End If
Value = Dir
Loop
For Each Folder In Folders
Recursive FolderPath & Folder & "\"
Next Folder
End Sub
I found this code:
Add missing dates VBA
Sub InsertMissingDates()
Dim i As Long
Dim RowCount As Long
i = 4
Do
If Cells(i, 1) + 1 < Cells(i + 1, 1) Then
Rows(i + 1).Insert
Cells(i + 1, 1) = Cells(i, 1) + 1
End If
If (Cells(i + 1, 1) = "") Then
Cells(i + 1, 1) = Cells(i, 1) + 1
End If
i = i + 1
Loop Until Cells(i, 1).Value >= DateSerial(2016, 1, 30)
End Sub
How do I point to column E rather than it column A?
you need to change the parameter on Cells function
https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.cells
On Cells function the second parameter:
1- A
2- B
3- C
4- D
5- E
So if you change your Code and use 5 instead of 1 it will work on cell E
Sub InsertMissingDates()
Dim i As Long
Dim RowCount As Long
i = 4
Do
If Cells(i, 5) + 1 < Cells(i + 1, 5) Then
Rows(i + 1).Insert
Cells(i + 1, 5) = Cells(i, 5) + 1
End If
If (Cells(i + 1, 5) = "") Then
Cells(i + 1, 5) = Cells(i, 5) + 1
End If
i = i + 1
Loop Until Cells(i, 5).Value >= DateSerial(2016, 1, 30)
End Sub
Use a parameter to determine the column:
Sub InsertMissingDates()
Dim i As Long
Dim RowCount As Long
Dim WhichCol As String
i = 4
WhichCol = "D"
Do
If Cells(i, WhichCol) + 1 < Cells(i + 1, WhichCol) Then
Rows(i + 1).Insert
Cells(i + 1, WhichCol) = Cells(i, WhichCol) + 1
End If
If (Cells(i + 1, WhichCol) = "") Then
Cells(i + 1, WhichCol) = Cells(i, WhichCol) + 1
End If
i = i + 1
Loop Until Cells(i, WhichCol).Value >= DateSerial(2016, 1, 30)
End Sub
I would like to ask how to shorten the code below? Have any other ways to achieve the same result?
Option Explicit
Sub test()
Dim i As Integer
Dim nRow As Integer: nRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To nRow
If Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) And Cells(i + 3, 1) = Cells(i + 4, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2) & "/" & Cells(i + 4, 2)
Rows(i + 1 & ":" & i + 4).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2)
Rows(i + 1 & ":" & i + 3).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2)
Rows(i + 1 & ":" & i + 2).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2)
Rows(i + 1 & ":" & i + 1).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) = "" Then
Exit For
End If
Next i
End Sub
Thank you!
Here's Dictionary based approach which should work for you.
Public Sub RearrangeData()
Dim objDic As Object
Dim varRng
Dim i As Long
Set objDic = CreateObject("Scripting.Dictionary")
objDic.CompareMode = vbTextCompare '\\ change this if you need it case sensitive
varRng = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
For i = LBound(varRng) To UBound(varRng)
If objDic.Exists(varRng(i, 1)) Then
objDic.Item(varRng(i, 1)) = objDic.Item(varRng(i, 1)) & "/" & varRng(i, 2)
Else
objDic.Add varRng(i, 1), varRng(i, 2)
End If
Next i
Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
Range("A2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Keys)
Range("B2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Items)
Set objDic = Nothing
End Sub
here's another dictionary approach (no reference adding required)
Sub strings()
Dim data As Variant, key As Variant
Dim i As Long
data = Range("B2", Cells(Rows.Count, 1).End(xlUp)).Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(data)
.Item(data(i, 1)) = .Item(data(i, 1)) & "/" & data(i, 2)
Next
Range("A1").CurrentRegion.Resize(Range("A1").CurrentRegion.Rows.Count - 1).Offset(1).ClearContents
i = 1
For Each key In .Keys
i = i + 1
Cells(i, 1) = key
Cells(i, 2) = Mid(.Item(key), 2)
Next
End With
End Sub
BTW, should you ever need to combine strings from more columns, you could use
Option Explicit
Sub strings()
Dim data As Variant, key As Variant
Dim i As Long, iCol As Long
With Range("A1").CurrentRegion
With .Resize(.Rows.Count - 1).Offset(1)
data = .Value
.ClearContents
End With
End With
With CreateObject("Scripting.Dictionary")
For iCol = 2 To UBound(data, 2)
For i = 1 To UBound(data)
.Item(data(i, 1)) = Trim(.Item(data(i, 1)) & " " & data(i, iCol))
Next
Range("A2").Resize(.Count) = Application.Transpose(.Keys)
Range("A2").Resize(.Count).Offset(, iCol - 1) = Application.Transpose(.Items)
.RemoveAll
Next
End With
Range("a1").CurrentRegion.Replace what:=" ", replacement:="/", lookat:=xlPart
End Sub