I have a macro that works fine pasting an array in a column, now I want to paste a new array in the second column, the problem is that to paste the value it has to fulfill some conditions, so I have to nest an if condition inside another one, it gives me no error but it doesn't work...
this is what I have:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A, L:L")) Is Nothing Then
On Error GoTo Fìn
Application.EnableEvents = False
Dim i As Long, n As Long
Dim arrmatrix As Variant
ReDim arrmatrix(1 To 1, 1 To 1)
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 12).Value = "Pi emitida" Then
n = n + 1
ReDim Preserve arrmatrix(1 To 1, 1 To n)
arrmatrix(1, n) = Cells(i, 1).Value
End If
Next i
With Worksheets("Inicio")
.Range("G4:G" & Rows.Count).ClearContents
.Range("G4").Resize(UBound(arrmatrix, 2), 1) = Application.Transpose(arrmatrix)
End With
End If
If Not Intersect(Target, Range("A:A, Q:Q,L:L")) Is Nothing Then
On Error GoTo Fìn
Application.EnableEvents = False
Dim j As Long, m As Long
Dim arrmatrix1 As Variant
ReDim arrmatrix1(1 To 1, 1 To 1)
For j = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'THIS IS THE PROBLEM.....!!!!!!!!!!!!!!!
If Cells(j, 12).Value = "Pi emitida" Or Cells(j, 12).Value = "PI firmada" Or Cells(j, 12).Value = "Carta credito L/c" Or Cells(j, 12).Value = "Con booking" Then
If DateDiff(d, Cells(j, 17).Value, Today) > 0 Then
m = m + 1
ReDim Preserve arrmatrix1(1 To 1, 1 To m)
arrmatrix1(1, m) = Cells(j, 1).Value
End If
Next j
With Worksheets("Inicio")
.Range("H4:H" & Rows.Count).ClearContents
.Range("H4").Resize(UBound(arrmatrix1, 2), 1) = Application.Transpose(arrmatrix1)
End With
End If
Fìn:
Application.EnableEvents = True
End Sub
try this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A, L:L")) Is Nothing Then
On Error GoTo Fìn
Application.EnableEvents = False
Dim i As Long, n As Long
Dim arrmatrix As Variant
ReDim arrmatrix(1 To 1, 1 To 1)
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 12).Value = "Pi emitida" Then
n = n + 1
ReDim Preserve arrmatrix(1 To 1, 1 To n)
arrmatrix(1, n) = Cells(i, 1).Value
End If
Next i
With Worksheets("Inicio")
.Range("G4:G" & Rows.Count).ClearContents
.Range("G4").Resize(UBound(arrmatrix, 2), 1) = Application.Transpose(arrmatrix)
End With
End If
If Not Intersect(Target, Range("A:A, Q:Q,L:L")) Is Nothing Then
On Error GoTo Fìn
Application.EnableEvents = False
Dim j As Long, m As Long
Dim arrmatrix1 As Variant
ReDim arrmatrix1(1 To 1, 1 To 1)
For j = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'THIS IS THE PROBLEM.....!!!!!!!!!!!!!!!
If Cells(j, 12).Value = "Pi emitida" Or Cells(j, 12).Value = "PI firmada" Or Cells(j, 12).Value = "Carta credito L/c" Or Cells(j, 12).Value = "Con booking" Then
If DateDiff(d, Cells(j, 17).Value, Today) > 0 Then
m = m + 1
ReDim Preserve arrmatrix1(1 To 1, 1 To m)
arrmatrix1(1, m) = Cells(j, 1).Value
End If
End If
Next j
With Worksheets("Inicio")
.Range("H4:H" & Rows.Count).ClearContents
.Range("H4").Resize(UBound(arrmatrix1, 2), 1) = Application.Transpose(arrmatrix1)
End With
Fìn:
Application.EnableEvents = True
End Sub
Related
I have a for next loop that runs through a couple hundred thousand lines making changes on most. Could an array to make this code run faster?
The example of my for loop. Sometimes it gets overloaded and crashes Excel. (FYI my loop has to run bottom to top for it to do its intended purpose.)
Sub RemoveDuplicates()
Dim shWorkBook As Worksheet
Dim wkb As Workbook
Dim FullYearData As Worksheet
Set wkb = ThisWorkbook
With wkb
Set shWorkBook = .Sheets("Workbook")
Set shFullYearData = .Sheets("FullYearData")
End With
Dim i As Long
Dim LastRowW As Long
On Error Resume Next
Call TurnOffCalc
FirstRowW = shWorkBook.Cells(1, 1).Row
FirstColW = shWorkBook.Cells(1, 1).Column
LastRowW = shWorkBook.Cells(Rows.Count, 1).End(xlUp).Row
LastColW = shWorkBook.Cells(2, Columns.Count).End(xlToLeft).Column
i = LastRowW
Sum = 0
shWorkBook.Activate
For i = LastRowW To 1 Step -1
If shWorkBook.Cells(i, 7) = shWorkBook.Cells(i - 1, 7) Then
shWorkBook.Cells(i, 26) = vbNullString
End If
If shWorkBook.Cells(i, 26).Value <> "" Then
shWorkBook.Cells(i, 27) = Sum + Cells(i, 25).Value
Sum = 0
ElseIf shWorkBook.Cells(i, 26).Value = "" Then
Sum = shWorkBook.Cells(i, 25).Value + Sum
End If
Next
p = FirstRowW + 1
For p = FirstRowW + 1 To LastRowW Step 1
shWorkBook.Cells(p, 28) = Application.WeekNum(shWorkBook.Cells(p, 3))
Next
shWorkBook.Cells(1, 28).Value = "Week Number"
Call TurnOnCalc
End Sub
Try something like this:
Sub RemoveDuplicates()
Dim shWorkBook As Worksheet
Dim wkb As Workbook
Dim FullYearData As Worksheet
Dim i As Long, Sum
Dim LastRowW As Long, LastColW As Long, tbl As Range, data
Set wkb = ThisWorkbook
With wkb
Set shWorkBook = .Sheets("Workbook")
'Set shFullYearData = .Sheets("FullYearData")
End With
LastRowW = shWorkBook.Cells(Rows.Count, 1).End(xlUp).Row
LastColW = shWorkBook.Cells(2, Columns.Count).End(xlToLeft).Column
Set tbl = shWorkBook.Range("A1").Resize(LastRowW, 28) 'include "Week number" (?)
data = tbl.Value 'get the range value as an array
data(1, 28) = "Week Number"
Sum = 0
For i = LastRowW To 1 Step -1
If data(i, 7) = data(i - 1, 7) Then data(i, 26) = vbNullString
If data(i, 26).Value <> "" Then
data(i, 27) = Sum + data(i, 25).Value
Sum = 0
Else
Sum = data(i, 25).Value + Sum
End If
If i > 1 Then data(i, 28) = CLng(Format(data(i, 3), "ww"))
Next
tbl.Value = data 'return the data
End Sub
I have two buttons which cycles through records (employees in this case).
Button one is Previous Record and it will navigate through all the emoloyees up till the first emoloyee. After reaching first employee, the button won't do anything.
But, for the *next record * button, for some reason, after going to the last visible employ, pressing it once again will go to a new or **blank ** record.
Not sure how to fix the bug,
Help is highly appreciated thanks!
Sub WinLossSplit()
Dim ws As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name <> "Sheet1" And ws.Name <> "Sheet2" Then
If Application.WorksheetFunction.CountA(ws.Range("A:A")) > 0 Then
ws.Range("A:A").TextToColumns Destination:=ws.Range("A:B"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=True, OtherChar _
:=True, FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
End If
End If
Next ws
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("done")
End Sub
Sub hello()
Dim a, i As Long, w(), k(), n As Long
Dim dic As Object, ws As Worksheet, s As String
For Each ws In Worksheets
dic.comparemode = vbTextCompare
'With Sheets("Sheet1")
a = ws.Range("a1:b" & ws.Range("a" & Rows.Count).End(xlUp).Row)
'End With
ReDim w(1 To UBound(a, 1), 1 To 2)
Set dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(a, 1)
If Not IsEmpty(a(i, 1)) Then
' If Not dic.exists(a(i, 1)) Then
' n = n + 1
' w(n, 1) = a(i, 1): w(n, 2) = a(i, 2)
' dic.Add a(i, 1), Array(n, 2)
'Else
k = dic.Item(a(i, 1))
w(k(0), 2) = w(k(0), 2) & "," & a(i, 2)
dic.Item(a(i, 1)) = k
'End If
End If
Next
On Error Resume Next
'Set ws = Sheets("FinalReport")
On Error GoTo 0
If ws Is Nothing Then
' Set ws = Worksheets.Add: ws.Name = "FinalReport"
End If
With ws.Range("a1")
'.Resize(, 2).Value = Array("Array", "Datetime period")
.Resize(, 1).Value = Array("Array", "Datetime period")
For i = 1 To n
If Len(w(i, 2)) > 1024 Then
s = w(i, 2)
.Offset(i).Value = w(i, 1)
.Offset(i, 1).Value = s
Else
.Offset(i).Value = w(i, 1)
.Offset(i, 1).Value = w(i, 2)
End If
Next
' puts in separate columns rather than string with commas
.Offset(1, 1).Resize(n).TextToColumns _
Destination:=.Offset(1, 1), DataType:=xlDelimited, Comma:=True
End With
Set dic = Nothing: Erase a
Next ws
End Sub
It's not a bug, it's by design.
If you don't like this, set the form's property AllowAdditions to False.
I have written a VBA Macro which works, but takes too long because the database is also very big.
I know this can be optimized via Arrays, but I am not sure how to make it.
Could someone help me please?
'Identify how many rows are in the file
finalrow = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row
'fill the empty fields which requires the part number and description
For i = 2 To finalrow
If Cells(i, 3) = 0 Or Cells(i, 3) = "------------" Or Cells(i, 3) = "e" Or Cells(i, 3) = "111)" Or Cells(i, 3) = "ion" Then
If Cells(i, 4) = 0 Or Cells(i, 4) = "-----------" Or Cells(i, 4) = "Location" Then
Range("A" & i & ":H" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
Else
For j = 1 To 3
Cells(i, j) = Cells(i - 1, j)
Next
End If
End If
If Cells(i, 1) = 0 Then
Cells(i, 1) = Cells(i - 1, 1)
End If
If Cells(i, 4) = 0 Then
Range("A" & i & ":H" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
End If
Count = Count + 1
If Count = finalrow Then
i = finalrow
End If
Next
I combined your code with my answer to excel Delete rows from table Macro based on criteria, that I just finished posting. It is super fast. Please check out my other answer for details.
You may need to adjust the Target range. If your data starts in A1 and does not have any completely blank rows than it should work.
Sub DeleteRows()
Dim Start: Start = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Const PreserveFormulas As Boolean = True
Dim Target As Range
Dim DeleteRow As Boolean
Dim Data, Formulas, NewData
Dim pos As Long, x As Long, y As Long
Set Target = Range("A1").CurrentRegion
Data = Target.Value
If PreserveFormulas Then Formulas = Target.Formula
ReDim NewData(1 To UBound(Data, 1), 1 To UBound(Data, 2))
For x = 2 To UBound(Data, 1)
DeleteRow = True
If Data(x, 3) = 0 Or Data(x, 3) = "------------" Or Data(x, 3) = "e" Or Data(x, 3) = "111)" Or Data(x, 3) = "ion" Then
If Data(x, 4) = 0 Or Data(x, 4) = "-----------" Or Data(x, 4) = "Location" Then
DeleteRow = False
End If
End If
If Data(x, 4) = 0 Or Data(x, 4) = "-----------" Or Data(x, 4) = "Location" Then DeleteRow = False
If Not DeleteRow Then
pos = pos + 1
For y = 1 To UBound(Data, 2)
If PreserveFormulas Then
NewData(pos, y) = Formulas(x, y)
Else
NewData(pos, y) = Data(x, y)
End If
Next
End If
Next
Target.Formula = NewData
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print "Execution Time: "; Timer - Start; " Second(s)"
End Sub
I'd start simply with this:
'Identify how many rows are in the file
finalrow = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row
'fill the empty fields which requires the part number and description
For i = 2 To finalrow
Set ci3 = Cells(i, 3)
If ci3 = 0 Or ci3 = "------------" Or ci3 = "e" Or ci3 = "111)" Or ci3 = "ion" Then
Set ci4 = Cells(i, 4)
If ci4 = 0 Or ci4 = "-----------" Or ci4 = "Location" Then
Range("A" & i & ":H" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
Else
For j = 1 To 3
Cells(i, j) = Cells(i - 1, j)
Next
End If
End If
If Cells(i, 1) = 0 Then
Cells(i, 1) = Cells(i - 1, 1)
End If
If Cells(i, 4) = 0 Then
Range("A" & i & ":H" & i).Select
Selection.Delete Shift:=xlUp
i = i - 1
End If
Count = Count + 1
If Count = finalrow Then
i = finalrow
End If
Next
I am currently trying to input data from an export sheet from MS Project. I have produced the data on worksheet1 and I am attempting to reproduce what I have created in an excel page.
I am at the early stages and I have written some code. I have looked up the error and I cannot see where I am going wrong. To start with, i just want to input a sub section of the data into an array so I can manipulate it later on.
The debug is highlighting the following line:
If Worksheets("Sheet1").Cells(i, 9).Value = Worksheets("Sheet2").Cells(j, 1).Value Then
I am a C++ programmer so I thought my array manipulation was ok but this is my second day on VBA so take it easy on me!
Code Below:
Private Sub CommandButton1_Click()
Dim i As Integer
Dim j As Integer
Dim Arr(2, 11) As Variant
j = 5
For i = 1 To 10
If Worksheets("Sheet1").Cells(i, 9).Value = Worksheets("Sheet2").Cells(j, 1).Value Then Arr(0, i) = Worksheets("Sheet1").Cells(i, 4).Value And Arr(1, i) = Worksheets("Sheet1").Cells(i, 6).Value And Arr(2, i) = Worksheets("Sheet1").Cells(i, 7).Value
Next i
MsgBox ("Value in Array index 2,2 : " & Arr(2, 2))
End Sub
Does this work:
Private Sub CommandButton1_Click()
Dim i As Integer
Dim j As Integer
Dim Arr(2, 11) As Variant
j = 5
For i = 1 To 10
If Worksheets("Sheet1").Cells(i, 9).Value = Worksheets("Sheet2").Cells(j, 1).Value Then
Arr(0, i) = Worksheets("Sheet1").Cells(i, 4).Value
Arr(1, i) = Worksheets("Sheet1").Cells(i, 6).Value
Arr(2, i) = Worksheets("Sheet1").Cells(i, 7).Value
End If
Next i
MsgBox ("Value in Array index 2,2 : " & Arr(2, 2))
End Sub
The "IF" statement didn't need those "ANDs" for when the statement is true. That might have been one of the issues. In VB (not sure about C++), when your IF statement is TRUE, everything after Then will occur, until the End If (or ElseIf), no need to say "do this, AND do this, AND do this...", it's just "Do this, this, this, this".
If ThisWorkbook.Worksheets("Sheet1").Cells(i, 9).Value = ThisWorkbook.Worksheets("Sheet2").Cells(j, 1).Value Then
Arr(0, i) = Worksheets("Sheet1").Cells(i, 4).Value
Arr(1, i) = Worksheets("Sheet1").Cells(i, 6).Value
Arr(2, i) = Worksheets("Sheet1").Cells(i, 7).Value
End If
Replace your long line of IF code with this. You also forgot to close your IF statement, and the AND statements are not needed, it just executes all code after THEN until it hits and END IF
I have this automatic procedure that works great
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A, L:L")) Is Nothing Then
On Error GoTo Fìn
Application.EnableEvents = False
Dim i As Long, n As Long
Dim arrmatrix As Variant
ReDim arrmatrix(1 To 1, 1 To 1)
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 12).Value = "Pi emitida" Then
n = n + 1
ReDim Preserve arrmatrix(1 To 1, 1 To n)
arrmatrix(1, n) = Cells(i, 1).Value
End If
Next i
With Worksheets("Inicio")
.Range("G4:G" & Rows.Count).ClearContents
.Range("G4").Resize(UBound(arrmatrix, 2), 1) = Application.Transpose(arrmatrix)
End With
End If
Fìn:
Application.EnableEvents = True
End Sub
My problem now is that I want to do the same and paste a different array in the colum next to the first one, the array must do the same but if these conditions are achieved:
dim hoy as date
hoy=date
If Cells(j, 12).Value = "Pi emitida" Or Cells(j, 12).Value = "PI firmada" Or Cells(j, 12).Value = "Carta credito L/c" Or Cells(j, 12).Value = "Con booking" And hoy - Cells(j, 12).Value >= 0
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, n As Long, Dim j As Long, m As Long
Dim arrmatrix() As Variant, Dim arrmatrix1() As Variant
If Not Intersect(Target, Range("A:A, L:L")) Is Nothing Then
' On Error GoTo Fìn 'Commented to find out which line your error actually is - Uncomment once fixed
Application.EnableEvents = False
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 12).Value = "Pi emitida" Then
n = n + 1
ReDim Preserve arrmatrix(1 To 1, 1 To n)
arrmatrix(1, n) = Cells(i, 1).Value
End If
If (Cells(i, 12).Value = "Pi emitida" Or Cells(i, 12).Value = "PI firmada" Or Cells(i, 12).Value = "Carta credito L/c" Or Cells(i, 12).Value = "Con booking") and DateDiff(d, Cells(i, 17).Value, Today) > 0 Then
m = m + 1
ReDim Preserve arrmatrix1(1 To 1, 1 To m)
arrmatrix1(1, m) = Cells(i, 1).Value
End If
Next i
With Worksheets("Inicio")
.Range("G4:G" & Rows.Count).ClearContents
.Range("G4").Resize(UBound(arrmatrix, 2), 1) = Application.Transpose(arrmatrix)
.Range("H4:H" & Rows.Count).ClearContents
.Range("H4").Resize(UBound(arrmatrix1, 2), 1) = Application.Transpose(arrmatrix1)
End With
End If
Fìn:
Application.EnableEvents = True
End Sub