I've tried by hours to cope with this error, search solutions, but nothing is clear for me.
I've imported successfully items from Excel to combobox (>19 appearances)
Now I have duplicates in combo. I wanna iterate by Excel sheet, compare with Combobox & remove unnecessary items (except single one)
I have
error 381 - Could not get the Column property array index.
Dim N As Long, K As Long, counter As Long
With Sheets("Główne")
N = .Cells(Rows.Count, 12).End(xlUp).Row
End With
Dim ostatnia As Long
ostatnia = Cells(Rows.Count, 11).End(xlUp).Row
For i = 1 To ostatnia
Range("I" & i + 1).Formula = "=COUNTIFS(L:L,L" & i + 1 & ")"
Next
ComboBox1.Clear
For K = 1 To N
If Cells(K + 1, 9).Value > 19 Then
ComboBox1.AddItem Sheets("Główne").Cells(K + 1, 12).Value
End If
Next K
Range("I2:I" & ostatnia).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'############### problem is somewhere below ##############'
For S = 2 To N
counter = 1
For iteracjalista = 0 To ComboBox1.ListCount - 1
If ComboBox1.Column(0, iteracjalista) = Sheets("Główne").Cells(S + 1, 12).Value Then
If Sheets("Główne").Cells(S + 1, 9).Value > counter Then
ComboBox1.RemoveItem 1
counter = counter + 1
End If
End If
Next iteracjalista
Next S
Probably problem is in last part of code. But I have no idea how I should fix it.
Could you help me?
In place of this Code
For K = 1 To N
If Cells(K + 1, 9).Value > 19 Then
ComboBox1.AddItem Sheets("Główne").Cells(K + 1, 12).Value
End If
Next K
Use this Code - It eliminates Duplicates before populating the ComboBox
Dim xList As String, xVal As String
' The following populates the ComboBox with Unique Values - No Duplicates
xList = ""
' We are using the colon character ":" as a separator
' You may wish to use something else
For K = 1 To N
xVal = Cells(K + 1, 9).Value
If xVal > 19 Then
If InStr(1, xList, ":" & xVal, vbTextCompare) = 0 Then
xList = xList & ":" & xVal
End If
End If
Next K
xList = Mid(xList, 2) ' Remove the leading : character
ThisWorkbook.Sheets("Glówne").ComboBox1.List = Split(xList, ":")
' Done
Then you can takeout all the existing code for deleting duplicates from the ComboBox .... All the following can be deleted
'############### problem is somewhere below ##############'
For S = 2 To N
counter = 1
For iteracjalista = 0 To ComboBox1.ListCount - 1
If ComboBox1.Column(0, iteracjalista) = Sheets("Główne").Cells(S + 1, 12).Value Then
If Sheets("Główne").Cells(S + 1, 9).Value > counter Then
ComboBox1.RemoveItem 1
counter = counter + 1
End If
End If
Next iteracjalista
Next S
Related
I have an excel sheet full of data sections, each data section is separated by an empty row.
While I'm looping over each row of the worksheet, I need to find the index of the next blank row so I can know where the current data section ends & apply modifications to it before passing to the next data section.
Here is an example of my first loop (inside this loop I need to find the index of the next blank row):
Dim x As Integer
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1").Select
For x = 1 To lastrow
If Left(Cells(x, "A").Value, 8) = "!JOURNAL" And Not (IsEmpty(Cells(x, "H"))) Then
'''Here I need to add another loop to find the index of my next blank row please'''
idxblankrow = Range(Cells(x, "A")).CurrentRegion.Row
MsgBox "Idx blank row is " & idxblkrow
Range(Cells(x + 2, "A"), Cells(idxblankrow - 1, "H")).Cut Range(Cells(x + 2, "B"), Cells(idxblankrow - 1, "I"))
Range(Cells(x, "H")).Select
Selection.Copy
Range(Cells(x + 2, "A"), Cells(idxblankrow - 1, "A")).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next
Here is another failed attempt(the second nest For loop is what tries to search for the blank row):
Dim x As Integer
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For x = 1 To lastrow
If Left(Cells(x, "A").Value, 8) = "!JOURNAL" And Not (IsEmpty(Cells(x, "H"))) Then
For j = x To lastrow
If IsEmpty(Cells(j, "A")) Then idxblankrow = Cells(j, "A").Row
MsgBox "blank row " & idxblankrow
Exit For
End If
Range(Cells(x + 2, "A"), Cells(idxblankrow - 1, "H")).Cut Range(Cells(x + 2, "B"), Cells(idxblankrow - 1, "I"))
Range(Cells(x, "H")).Select
Selection.Copy
Range(Cells(x + 2, "A"), Cells(idxblankrow - 1, "A")).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End If
Next
Any kind of help would be hella appreciated, thanks !
Please, use the next adapted way. It does not select, it does not use clipboard:
For x = 1 To LastRow
If left(cells(x, "A").Value, 8) = "!JOURNAL" And Not (IsEmpty(cells(x, "H"))) Then
idxblankrow = cells(x, "A").End(xlDown).Row
MsgBox "Idx blank row is " & idxblankrow
Range(cells(x + 2, "A"), cells(idxblankrow - 1, "H")).Cut cells(x + 2, "B")
'copy the value from "H" on the whole A:A column portion:
Range("A" & x & ":A" & idxblankrow - 1).Value = cells(x, "H").Value 'not using clipboard...
Stop 'check when stopped here if it did what you need
'if so, please press F5 to continue and check again.
'you probably need to increment x to continue iteration after the processed portion
'something as:
x = x + (idxblankrow - x) + 2 '???
End If
Next x
You probably need now to increment x with the number of rows which have been processed, but you must explain in words what you try accomplishing. Guessing is not an appropriate way of working here...
If I want to know if an entire row is empty, I just concatenate the whole row and check the length. If this is zero, then the row is blank. Else, it's not.
See following exemplary screenshot (only the fourth row is empty, which is seen in the fourth formula, giving zero as a result):
Use flags to identify the start and end of the group. This deals with multiple blank rows between groups.
Sub macro()
Dim ws As Worksheet
Dim lastrow As Long, i As Long, n As Long
Dim x As Long, z As Long
Dim bStart As Boolean, bEnd As Boolean
Set ws = ThisWorkbook.Sheets("Sheet1")
n = 0
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
' start of group
If Len(.Cells(i, "A")) > 0 Then
bStart = True
n = n + 1
End If
' end of group look ahead
If Len(.Cells(i + 1, "A")) = 0 Then
bEnd = bStart
End If
' valid range
If bStart And bEnd Then
x = i - n + 1 ' first row of group
MsgBox "Processing rows " & x & " to " & i
If Left(.Cells(x, "A").Value, 8) = "!JOURNAL" _
And Not (IsEmpty(Cells(x, "H"))) Then
' process rows x to i
End If
' reset flags
n = 0
bStart = False
bEnd = False
End If
Next
End With
End Sub
All these answers could be much simpler. Consider this:
iNextBlankRow = Sheet1.Range("A" & iNextBlankRow & ":A50").SpecialCells(xlCellTypeBlanks).Cells(1, 1).Row
To demonstrate, run this macro:
Sub BlankRowTest()
Dim iNextBlankRow As Long
Dim r As Long
iNextBlankRow = 1
For r = 1 To 50
If iNextBlankRow <= r Then iNextBlankRow = Sheet1.Range("A" & iNextBlankRow + 1 & ":A50").SpecialCells(xlCellTypeBlanks).Cells(1, 1).Row
Debug.Print r, iNextBlankRow, "'" & Sheet1.Cells(r, 1).Value & "'"
Next
End Sub
This code loops through the first 50 rows looking for the next blank row. When it finds it, it assigns it to the variable iNextBlankRow. We don't bother updating that until our current row (r) is greater than or equal to INextBlankRow. At that point we look again starting from the next row.
I'm trying to make a macro that increases the time between data points as part of automatic data processing, but it currently takes way too long.
One of my sensors logs a data point every 10 seconds, I want to increase this dt to 1 hour. For this I wrote some very simple (inefficient) code (see below) that does work but takes 10-40 minutes to process 1 week of data which is far from ideal.
I've seen recommendations for semi-similar issues to use an array, however I have 0 experience with this and don't know if it's applicable to this goal.
Do While Cells(row + 1, 2).Value <> ""
If Cells(row + 1, 2).Value - Cells(row, 2).Value < 1 / 24.05 Then
Rows(row + 1).Select
Selection.Delete Shift:=xlUp
Else
row = row + 1
End If
Loop
EDIT:
I solved my issue with a slightly edited version of #Damian's code as shown below.
Sub Change_dt()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim target As Single
target = Sheets("Controller").Cells(16, 9).Value
Dim arrSource As Variant
With ThisWorkbook.Sheets("Raw data")
arrSource = .UsedRange.Value 'this will input the whole used sheet inside the array
Dim finalArr As Variant
ReDim finalArr(1 To UBound(arrSource), 1 To UBound(arrSource, 2))
.Cells.Delete 'will clean the worksheet
Dim i As Long, x As Long, j As Long, Z As Long
x = 1
Z = 1
For i = 1 To UBound(arrSource)
On Error Resume Next
If arrSource(i + Z, 1) = vbNullString Or i = UBound(arrSource) Then Exit For 'will end the loop once the next row is empty
On Error GoTo 0
'If the next row substracted the first is greater than target both will be copied to the final array
If arrSource(i + Z, 1) - arrSource(i, 1) > target Then
For j = 1 To UBound(arrSource, 2)
finalArr(x, j) = arrSource(i, j)
finalArr(x + 1, j) = arrSource(i + Z, j)
Next j
x = x + 2 'increment 2 on x because you wrote 2 lines
i = i + Z
Z = 1
Else
Z = Z + 1
End If
Next i
'paste the resulting array back to the sheet
.Range("A1", .Cells(UBound(finalArr), UBound(finalArr, 2))).Value = finalArr
'eliminate the extra unused rows
i = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Rows(i & ":" & .Rows.Count).Delete
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This should help a lot in your executing time:
Sub Change_dt()
Dim target As Single
target = Sheets("Controller").Cells(16, 9).Value
Dim arrSource As Variant
With ThisWorkbook.Sheets("Raw data")
arrSource = .UsedRange.Value 'this will input the whole used sheet inside the array
Dim finalArr As Variant
ReDim finalArr(1 To UBound(arrSource), 1 To UBound(arrSource, 2))
.Cells.Delete 'will clean the worksheet
Dim i As Long, x As Long, j As Long
x = 1
For i = 5 To UBound(arrSource)
On Error Resume Next
If arrSource(i + 1, 2) = vbNullString Or i = UBound(arrSource) Then Exit For 'will end the loop once the next row is empty
On Error GoTo 0
'If the next row substracted the first is greater than 1/24.05 both will be copied to the final array
If Not arrSource(i + 1, 2) - arrSource(i, 2) < target Then
For j = 1 To UBound(arrSource, 2)
finalArr(x, j) = arrSource(i, j)
finalArr(x + 1, j) = arrSource(i + 1, j)
Next j
x = x + 2 'increment 2 on x because you wrote 2 lines
End If
Next i
'paste the resulting array back to the sheet
.Range("A1", .Cells(UBound(finalArr), UBound(finalArr, 2))).Value = finalArr
'eliminate the extra unused rows
i = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Rows(i & ":" & .Rows.Count).Delete
End With
End Sub
I have created a nested for loop to compare 3 different cell values within 2 sheets. The loop works fine when the data is small, but when I run on 5,000 rows its too slow and crashes excel. Any idea of how to run this more efficiently.
Sub RowMatch()
Dim x As Integer
' Make sure we are in the right sheet
Worksheets("Q416").Activate
' Set numrows = number of rows of data.
NumRows = Range("C2", Range("C2").End(xlDown)).Rows.count
' find the reference range
Worksheets("Q415").Activate
NumRows2 = Range("C5", Range("C5").End(xlDown)).Rows.count
Worksheets("Q416").Activate
MsgBox ("Total # of Rows on this sheet = " & NumRows & " and " & NumRows2 & " in Ref Range")
Range("A1").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
'MsgBox NumRows2
For y = 1 To NumRows2
'MsgBox (ActiveCell.Offset(x, 0).Value & " & " & Worksheets("Q415").Cells(y + 1, 1))
If ActiveCell.Offset(x, 0).Value = Worksheets("Q415").Cells(y + 1, 1).Value _
And ActiveCell.Offset(x, 2).Value = Worksheets("Q415").Cells(y + 1, 3).Value Then
If ActiveCell.Offset(x, 5).Value = Worksheets("Q415").Cells(y + 1, 6).Value Then
'If NumRows(i).Value = ActiveCell.Offset(1, 0).Value Then
ActiveCell.Offset(x, 10).Value = "Same"
Else
ActiveCell.Offset(x, 10).Value = ActiveCell.Offset(x, 5).Value - Worksheets("Q415").Cells(y + 1, 6).Value
End If
End If
Next y
Next x
End Sub
Reading and writing to cells is one of the slowest operations you can do in Excel VBA. Instead, you should place the values contained in the worksheets into arrays and work with them there, Here is an excellent reference: http://www.cpearson.com/excel/ArraysAndRanges.aspx. Use your NumRows variables and either a column letter or number to define the ranges that will consitute the arrays e.g:
myRange = Range("A1:C" & NumRows)
myArray = myRange.value
From the link to Chip Pearsons site:
Dim Arr() As Variant
Arr = Range("A1:B10")
Dim R As Long
Dim C As Long
For R = 1 To UBound(Arr, 1) ' First array dimension is rows.
For C = 1 To UBound(Arr, 2) ' Second array dimension is columns.
Debug.Print Arr(R, C)
Next C
Next R
I have a big table in excel, which contains about 8000 rows of data. I am working on a procedure to enable the users to receive a pdf copy of what they are looking for. (A detail list related to a work order).
I tried two different approaches, first copying the work order items after filtering it to a third sheet and then copying selected fields of data to the final form. It was good and fast.
second, after filter directly copying data of unhidden rows to the final form. (also more sort and remove duplicated items happen too)
The second one is very time killing (3 to 5 minutes) and very heavy.
Now, I am thinking of first sorting the data in a way that my desired item (what the user is looking for) comes to the first of table so after the filter, I just ask the loop to go until a visible number of rows, not until the end of rows.
Has anyone any idea, or better solution?
Cheers and merry Christmas!
Sub kit_Click()
' On Error GoTo Errorhandler
Dim wc As String
Dim c As Integer
Dim tbl As Range
Dim sel As Range
Dim des As Range
Dim m As Integer
Dim j As Integer
Dim aggrow As Integer
Dim varResult As Variant
Dim kf As Worksheet
Set kf = Worksheets("Kit Form")
a = ""
' Application.ScreenUpdating = False
' finding W/B code to prepare
If Not Intersect(ActiveCell, Range("d2:d3")) Is Nothing Then
a = Cells(2, 7).Value
GoTo body
ElseIf ActiveCell.Row < 6 Then a = InputBox("please specify the W/B you want to prepare KIT form for that", "W/B Number")
ElseIf ActiveCell.Row > ActiveSheet.UsedRange.Rows.Count Then a = InputBox("please specify the W/B you want to prepare KIT form for that", "W/B Number")
Else: a = Cells(ActiveCell.Row, 2).Value
End If
body:
On Error GoTo skip
wc = WorksheetFunction.VLookup(a, Range("b5:c1000"), 2, 0)
skip:
If a = "" Or a = "0" Then
a = InputBox("please specify the W/B you want to prepare KIT form for that", "W/B Number")
Else
' Cleaning KIT FORM
If Not kf.ListObjects("KitForm").DataBodyRange Is Nothing Then kf.ListObjects("KitForm").DataBodyRange.EntireRow.Delete
' Filtering the W/B Kittable items
With Sheets("FTV3")
.Range("tbl").AutoFilter Field:=3, Criteria1:="*" & a & "*", Operator:=xlFilterValues
.Range("tbl").AutoFilter Field:=25, Criteria1:="OK", Operator:=xlFilterValues
' Unhidding the Columns and copying the header row
.Cells.EntireColumn.Hidden = False
' Copying the data to Form
lstrw = .Cells(Rows.Count, 8).End(xlUp).Row
kf.Cells(2, 2) = a
kf.Cells(1, 4) = wc
m = 1
For i = 2 To lstrw
If .Rows(i).EntireRow.Hidden Then
m = m + 1
Else
kf.Rows(i - m + 4).RowHeight = 25
kf.Cells(i - m + 4, 1).Value = i - m
If .Cells(i, 21).Value = "_N/A" Then
kf.Cells(i - m + 4, 2) = "'"
Else
kf.Cells(i - m + 4, 2) = .Cells(i, 21)
End If
kf.Cells(i - m + 4, 3).Value = .Cells(i, 4).Value
If .Cells(i, 4).Value <> "_Book" Then kf.Cells(i - m + 4, 4).Value = .Cells(i, 26).Value
Worksheets("Kit Form").Cells(i - m + 4, 5).Value = .Cells(i, 7).Value
If .Cells(i, 8).Value <> "N/T" Then kf.Cells(i - m + 4, 6).Value = .Cells(i, 8).Value
If .Cells(i, 12).Value <> "_N/A" Then ttt = .Cells(i, 12) 'Or .Cells(i, 22).Value <> ""
kf.Cells(i - m + 4, 7).Value = "(( " & .Cells(i, 27).Value & " ))" & Chr(10) & ttt
kf.Rows(i - m + 4).AutoFit
If kf.Rows(i - m + 4).RowHeight < 25 Then kf.Rows(i - m + 4).RowHeight = 25
End If
Next
.Range("A:B,S:ac").EntireColumn.Hidden = True
aggrow = kf.Cells(Rows.Count, 1).End(xlUp).Row - 4
.Range("tbl").AutoFilter
End With
Call remove_duplicate
R = MsgBox("Successfuly Total of " & lstrw - m - 1 & " Items, aggregated in " & aggrow & " Rows of material Copied to the Kit Form " & Chr(10) & Chr(10) & "Do you want an PDF version of The form being prepared for you?", vbYesNo, "Result")
If R = 6 Then Call export_pdf
End If
End Sub
I'm trying to make a loop that will go thru this data set.
This is how the output should look.
Im still getting the hang of loops, but this is what i have so far:
Private Sub CommandButton1_Click()
Dim i As Long, j As Long, k As Byte, iLines As Long
j = 1
For i = 1 To 25
For k = 1 To 8
If k = 1 Then
Cells(j, 10).Value = Len(Cells((j + 2), 1).Value) - Len(Replace(Cells((j + 2), 1).Value, ",", "")) + 1
Cells(i, 11).Value = "SET"
Cells(i, 12).Value = Cells(i, 1).Value
End If
Next k
Next i
End Sub
My problem is on my loop output at the moment. It only counts the commas in the first data set and not the other ones. Also where it outputs SET it copies down instead of just putting it in one cell. See Below.
I will probably have more question as i progress along. Thanks in advance for the help!
Try this:
Whenever possible get rid of the loop. I replaced it with a find to find the next cell with "HW" in it. It will automatically step from one "HW" to the Next.
When using steps anchor everything on the one row and expand selection using resize.
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim i As Long
Dim k As Long
Set ws = ActiveSheet
With ws
For i = 1 To 200
If Left(.Cells(i, 1).Value, 2) = "HW" Then
On Error Resume Next
k = .Range(.Cells(i + 1, 1), .Cells(200, 1)).Find("HW").Row
On Error GoTo 0
If k <= i Then k = 200
.Cells(i, 10).Value = Len(Cells((i + 2), 1).Value) - Len(Replace(Cells((i + 2), 1).Value, ",", "")) + 1
.Cells(i, 11).Value = "SET"
.Cells(i, 12).Resize(k - i).Value = .Cells(i, 1).Resize(k - i).Value
i = k - 1
End If
Next i
End With
End Sub