I am getting all the time error 381.. What is there wrong? If i use only 1 column it works, if i add 2nd and more it stops working.
I try to populate my rows which compile with "if statement".
it stops each time to work at 2nd column.
UserForm + some Data:
https://drive.google.com/open?id=1hfCAu2m7C4kISSPJSvyjWc-TvxBr-fOO
2nd Version of code:
Sub PopulateList2()
Dim rngName As Range
Dim ws As Worksheet
Dim i As Integer
Dim LastRow As Long
Set ws = E1G
With ListBoxAbg
.Clear
.ColumnCount = 2
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
For i = 1 To LastRow
If ws.Cells(i, 6).Value < Now() _
And ws.Cells(i, 6).Value <> vbNullString Then
.AddItem
.List(i - 1, 0) = ws.Cells(i, 1).Value
.List(i - 1, 1) = ws.Cells(i, 3).Value
End If
Next i
End With
End Sub
....
Sub PopulateList2()
Dim rngName As Range
Dim ws As Worksheet
Dim i As Integer
Dim LastRow As Long
Set ws = E1G
AbgeListField.Clear
AbgeListField.ColumnCount = 7
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
For i = 1 To LastRow
If ws.Cells(i, 6).Value < Now() _
And ws.Cells(i, 6).Value <> vbNullString Then
AbgeListField.AddItem ws.Cells(i, 1).Value
AbgeListField.List(i - 1, 1) = ws.Cells(i, 2).Value
AbgeListField.List(i - 1, 2) = ws.Cells(i, 3).Value
AbgeListField.List(i - 1, 3) = ws.Cells(i, 4).Value
AbgeListField.List(i - 1, 4) = ws.Cells(i, 5).Value
AbgeListField.List(i - 1, 5) = ws.Cells(i, 6).Value
AbgeListField.List(i - 1, 6) = ws.Cells(i, 7).Value
End If
Next i
End Sub
i found the answer in that post:
https://social.msdn.microsoft.com/Forums/office/en-US/f5619db9-be72-41e3-a353-54ebb021f936/runtime-error-381-could-not-set-the-list-property-invalid-property-array-index?forum=exceldev
i added new dim nxtItme As Long. it works perfect now:
Sub PopulateList2()
Dim rngName As Range
Dim ws As Worksheet
Dim i As Integer
Dim LastRow As Long
Dim nxtItem As Long
Set ws = E1G
nxtItem = 0
With ListBoxAbg
.Clear
.ColumnCount = 6
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
For i = 1 To LastRow
If ws.Cells(i, 6).Value < Now() _
And ws.Cells(i, 6).Value <> vbNullString Then
.AddItem
.List(nxtItem, 0) = ws.Cells(i, 1).Value
.List(nxtItem, 1) = ws.Cells(i, 3).Value
.List(nxtItem, 2) = ws.Cells(i, 4).Value
.List(nxtItem, 3) = ws.Cells(i, 5).Value
.List(nxtItem, 4) = ws.Cells(i, 6).Value
nxtItem = nxtItem + 1
End If
Next i
End With
End Sub
Related
'Private Sub CommandButton1_Click()
Dim MySheetu As String, ws As Worksheet
MySheetu = operationplan.Value
Set ws = Worksheets(MySheetu)
Dim a As Variant
Dim b As Long
Dim c As Variant
Dim d As Variant
Dim e As Variant
Dim str1 As String
Dim str2 As String
Dim lastrow As Long
Dim lastcol As Long
Dim lastrow2 As Long
Dim lastrow3 As Long
Dim i As Variant
Dim j As Variant
Dim k As Variant
Dim dsheet As Worksheet
lastrow = Worksheets(1).Cells(Rows.Count, 21).End(xlUp).Row
For a = 2 To lastrow
ws.Cells((a), 1).Value = Worksheets(1).Cells(a, 21).Value
ws.Cells((a), 2).Value = Worksheets(1).Cells(a, 22).Value
ws.Cells((a), 3).Value = Worksheets(1).Cells(a, 23).Value
ws.Cells((a), 4).Value = Worksheets(1).Cells(a, 20).Value
ws.Cells((a), 5).Value = Worksheets(1).Cells(a, 26).Value
ws.Cells((a), 6).Value = Worksheets(1).Cells(a, 1).Value
ws.Cells((a), 7).Value = Worksheets(1).Cells(a, 1).Value
Next a
ws.Cells(1, 1).Value = "operasyon"
ws.Cells(1, 2).Value = "öncelik"
ws.Cells(1, 3).Value = "ardillik"
ws.Cells(1, 4).Value = "operasyon süresi"
ws.Cells(1, 5).Value = "sabit istasyon"
ws.Cells(1, 6).Value = "distinct_istasyon"
ws.Cells(1, 7).Value = "istasyon"
Columns(6).RemoveDuplicates Columns:=Array(1)
For b = lastrow To 1 Step -1
If Cells(b, 1).Text = "#N/A" Then
Rows(b).Delete
End If
Next b
lastrow2 = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow2
For j = 2 To lastrow2
If ws.Cells(i, 1).Value = ws.Cells(j, 2).Value Then
ws.Cells((j), 2) = i - 1
End If
Next j
Next i'
I got mismatch error in "If ws.Cells(i, 1).Value = ws.Cells(j, 2).Value Then" line how can i solve this error? I add additional codes below them. İ try cstr function but it cant work? Could you please help with these additional codes. The error is in the same line and it use user form text box value to refer the sheet
'Private Sub CommandButton1_Click()
Dim MySheetu As String, ws As Worksheet
MySheetu = operationplan.Value
Set ws = Worksheets(MySheetu)
Dim a As Variant
Dim b As Long
Dim c As Variant
Dim d As Variant
Dim e As Variant
Dim str1 As String
Dim str2 As String
Dim lastrow As Long
Dim lastcol As Long
Dim lastrow2 As Long
Dim lastrow3 As Long
Dim i As Variant
Dim j As Variant
Dim k As Variant
Dim dsheet As Worksheet
lastrow = Worksheets(1).Cells(Rows.Count, 21).End(xlUp).Row
For a = 2 To lastrow
ws.Cells((a), 1).Value = Worksheets(1).Cells(a, 21).Value
ws.Cells((a), 2).Value = Worksheets(1).Cells(a, 22).Value
ws.Cells((a), 3).Value = Worksheets(1).Cells(a, 23).Value
ws.Cells((a), 4).Value = Worksheets(1).Cells(a, 20).Value
ws.Cells((a), 5).Value = Worksheets(1).Cells(a, 26).Value
ws.Cells((a), 6).Value = Worksheets(1).Cells(a, 1).Value
ws.Cells((a), 7).Value = Worksheets(1).Cells(a, 1).Value
Next a
ws.Cells(1, 1).Value = "operasyon"
ws.Cells(1, 2).Value = "öncelik"
ws.Cells(1, 3).Value = "ardillik"
ws.Cells(1, 4).Value = "operasyon süresi"
ws.Cells(1, 5).Value = "sabit istasyon"
ws.Cells(1, 6).Value = "distinct_istasyon"
ws.Cells(1, 7).Value = "istasyon"
Columns(6).RemoveDuplicates Columns:=Array(1)
For b = lastrow To 1 Step -1
If Cells(b, 1).Text = "#N/A" Then
Rows(b).Delete
End If
Next b
lastrow2 = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow2
For j = 2 To lastrow2
If ws.Cells(i, 1).Value = ws.Cells(j, 2).Value Then
ws.Cells((j), 2) = i - 1
End If
Next j
Next i'
I got type mismatch error in the last fifth row that is "If ws.Cells(i, 1).Value = ws.Cells(j, 2).Value Then" How can I solve this.It is try to refer worksheet by using user form txt box value. In debugging it can be seen that I can get text box value but worksheet give type mismatch error.
I want to combine duplicate rows with the same A and C columns values and sum their cells values for the column B (by adding the value of the textbox2 from the duplicate to the original). My problem is about the condition of the "If" in the Loop. It doesn't consider those conditions when I have duplicates and just add a new row. Is there a better way to do this?
Private Sub CommandButton1_Enter()
ActiveSheet.Name = "Sheet1"
Dim lastrow As Long
With Sheets("Sheet2")
lastrow = .Cells(Rows.Count, "H").End(xlUp).Row
For x = lastrow To 3 Step -1
For y = 3 To lastrow
If .Cells(x, 1).Value = .Cells(y, 1).Value And .Cells(x, 3).Value = .Cells(y, 3).Value And x > y Then
.Cells(y, 8).Value = .Cells(y, 8).Value + TextBox2.Text
.Cells(y, 2).Value = .Cells(y, 2).Value + TextBox2.Text
.Rows(lastrow).EntireRow.Delete
Else
.Cells(lastrow + 1, 8).Value = TextBox2.Text
.Cells(lastrow + 1, 2).Value = TextBox2.Text
.Cells(lastrow + 1, 1).Value = TextBox1.Text
.Cells(lastrow + 1, 3).Value = TextBox3.Text
Exit For
End If
Next y
Next x
End With
End Sub
Here's a picture of the data
There's no blank cell in the column H (I changed the color of the font to make it invisible).
Create a primary key by joining the 2 columns with tilde ~ and use a Dictionary Object to locate duplicates.
Option Explicit
Private Sub CommandButton1_Click()
Dim wb As Workbook, ws As Worksheet
Dim iLastRow As Long, iRow As Long, iTarget As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet2")
iLastRow = ws.Cells(Rows.Count, "H").End(xlUp).Row
Dim dict As Object, sKey As String
Set dict = CreateObject("Scripting.Dictionary")
' build dictionary and
' consolidate any existing duplicates, scan up
For iRow = iLastRow To 3 Step -1
' create composite primary key
sKey = LCase(ws.Cells(iRow, 1).Value) & "~" & Format(ws.Cells(iRow, 3).Value, "yyyy-mm-dd")
If dict.exists(sKey) Then
iTarget = dict(sKey)
' summate and delete
ws.Cells(iTarget, 2) = ws.Cells(iTarget, 2) + ws.Cells(iRow, 2)
ws.Cells(iTarget, 8) = ws.Cells(iTarget, 8) + ws.Cells(iRow, 8)
ws.Rows(iRow).EntireRow.Delete
Else
dict(sKey) = iRow
End If
Next
' add new record from form using dictionary to locate any existing
iLastRow = ws.Cells(Rows.Count, "H").End(xlUp).Row
sKey = LCase(TextBox1.Text) & "~" & Format(DateValue(TextBox3.Text), "yyyy-mm-dd")
If dict.exists(sKey) Then
iTarget = dict(sKey)
ws.Cells(iTarget, 2) = ws.Cells(iTarget, 2) + TextBox2.Text
ws.Cells(iTarget, 8) = ws.Cells(iTarget, 8) + TextBox2.Text
Else
iTarget = iLastRow + 1
ws.Cells(iTarget, 1) = TextBox1.Text
ws.Cells(iTarget, 2) = TextBox2.Text
ws.Cells(iTarget, 3) = TextBox3.Text
ws.Cells(iTarget, 8) = TextBox2.Text
End If
End Sub
I have a listbox with values from a sheet called Database OUtypes. Values are:
Single Split
Multi Split
City Multi
I want a "MultiSplit"(textbox) that shows when value 2 is selected in listbox and hide when the other values are selected.
How can i do that ?
Option Explicit
Private Sub CommandButton3_Click()
Unload Me
Menu.Show
End Sub
Private Sub userform_activate()
Application.DisplayAlerts = False
Dim cell As Range
With Worksheets("Database Bedrijf")
For Each cell In .Range("B1:B1000" & .cells(Rows.Count, 3).End(xlUp).Row)
If Not IsEmpty(cell) Then Bedrijf.AddItem cell.Value
Next cell
End With
With Worksheets("Database Freon")
For Each cell In .Range("B1:B1000" & .cells(Rows.Count, 3).End(xlUp).Row)
If Not IsEmpty(cell) Then Freontype.AddItem cell.Value
Next cell
End With
With Worksheets("Database OUtypes")
For Each cell In .Range("B2:B1000" & .cells(Rows.Count, 3).End(xlUp).Row)
If Not IsEmpty(cell) Then OUtypes.AddItem cell.Value
Next cell
End With
'''This declares the data type of the variable "LstRw'
Dim LstRw As Long
'''This defines what the variable "LstRw' is to refer to. _
(The row number of the last used cell in column A.)
LstRw = cells(Rows.Count, "A").End(xlUp).Row
'''This tells the textbox named ID to equal the value of the last used cell in Col.A after adding 1 to it.
ID.caption = cells(LstRw, "A").Value + 1
End Sub
Private Sub Freontypes_Change()
gwp.Text = Application.VLookup(Freontype.Value, Worksheets("Database Freon").Range("B2:C1000"), 2, False)
End Sub
Private Sub Bedrijf_Change()
Dim RowMax As Integer
Dim wsh As Worksheet
Dim countExit As Integer
Dim CellCombo2 As String
Dim i As Integer
Set wsh = ThisWorkbook.Sheets("Database Klant")
RowMax = wsh.cells(Rows.Count, "B").End(xlUp).Row
'find last row of sheet in column A
Klant.Clear
'clear all value of comboBox2
With Klant
For i = 2 To RowMax
If wsh.cells(i, "B").Value = Bedrijf.Text Then
'Just show value of mapping with column A
.AddItem wsh.cells(i, "C").Value
Else
End If
Next i
End With
End Sub
Private Sub Freoninhoud_Change()
If Freoninhoud.Text = "" Then
MsgBox "Vul iets in"
Exit Sub
Else
Co2.Text = CDbl(Replace(Me.Freoninhoud.Text, ".", ",")) * gwp.Text
End If
End Sub
Private Sub Userform_Initialize()
Status.AddItem "Goed"
Status.AddItem "Slecht"
Status.AddItem "Defect"
Dim RowMax As Integer
Dim wsh As Worksheet
Dim countExit As Integer
Dim CellCombo1 As String
Dim i As Integer
Dim j As Integer
Set wsh = ThisWorkbook.Sheets("Database Bedrijf")
RowMax = wsh.cells(Rows.Count, "B").End(xlUp).Row
'find last row of sheet in column A
Bedrijf.Clear
'clear all value of comboBox1
With Bedrijf
For i = 2 To RowMax
'Run each row of column A
countExit = 0
CellCombo1 = wsh.cells(i, "B").Value
For j = i To 2 Step -1
'just show value not duplicate
If CellCombo1 = wsh.cells(j, "A").Value Then
countExit = countExit + 1
End If
Next j
If countExit = 0 Then
ElseIf countExit > 1 Then
Else
.AddItem CellCombo1
End If
Next i
End With
End Sub
Private Sub CommandButton1_Click()
Dim lRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Database OU")
lRow = ws.cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With ws
.cells(lRow, 1).Value = ID.caption
.cells(lRow, 2).Value = Bedrijf.Value
.cells(lRow, 3).Value = Klant.Value
.cells(lRow, 4).Value = Ruimte.Value
.cells(lRow, 5).Value = Merk.Value
.cells(lRow, 6).Value = Types.Value
.cells(lRow, 7).Value = Multisplit.Value
.cells(lRow, 8).Value = Model.Value
.cells(lRow, 9).Value = Serienummer.Value
.cells(lRow, 10).Value = Bouwjaar.Value
.cells(lRow, 11).Value = Afvoer.Value
.cells(lRow, 12).Value = Freontype.Value
.cells(lRow, 13).Value = Freoninhoud.Value
.cells(lRow, 14).Value = Co2.Text
.cells(lRow, 15).Value = Installatienummer.Value
.cells(lRow, 16).Value = Adres.Value
.cells(lRow, 17).Value = Status.Value
End With
Unload Me
Menu.Show
End Sub
Private Sub CommandButton2_Click()
Dim lRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Database OU")
lRow = ws.cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With ws
.cells(lRow, 1).Value = ID.caption
.cells(lRow, 2).Value = Bedrijf.Value
.cells(lRow, 3).Value = Klant.Value
.cells(lRow, 4).Value = Ruimte.Value
.cells(lRow, 5).Value = Merk.Value
.cells(lRow, 6).Value = Types.Value
.cells(lRow, 7).Value = Multisplit.Value
.cells(lRow, 8).Value = Model.Value
.cells(lRow, 9).Value = Serienummer.Value
.cells(lRow, 10).Value = Bouwjaar.Value
.cells(lRow, 11).Value = Afvoer.Value
.cells(lRow, 12).Value = Freontype.Value
.cells(lRow, 13).Value = Freoninhoud.Value
.cells(lRow, 14).Value = Co2.Text
.cells(lRow, 15).Value = Installatienummer.Value
.cells(lRow, 16).Value = Adres.Value
.cells(lRow, 17).Value = Status.Value
End With
Unload Me
Outoevoegen.Show
End Sub
Private Sub Userform_QueryClose(Cancel As Integer, closemode As Integer)
If closemode = vbFormControlMenu Then
MsgBox "Sorry gebruik de Sluiten knop"
Cancel = True
End If
End Sub
Found it
Private Sub OUtypes_Change()
If OUtypes = "Multi Split" Then
Label18.Visible = True
Multisplit.Visible = True
Else
Label18.Visible = False
Multisplit.Visible = False
End If
End Sub
Edit: This can be consolidated to be a bit more legible, by using booleans:
Private Sub OUtypes_Change()
visible = (OUtypes = "Multi Split") ' Boolean expression
Label18.Visible = visible
Multisplit.Visible = visible
End Sub
i have to sort data from sheet1 to sheet2 with reference to non-empty cell in column A. and
i have written code for it as below:
Sub polo()
Dim lastrow As Long
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = Sheets("Sheet1").Cells(i - 1, 2).Value
j = j + 1
End If
Next i
End Sub
But the problem is, i am getting result as in column D of sheet2.
I want result as shown in column E.
Please help.
Try this version:
Sub polo()
Dim lastrow As Long
Dim sTemp as String
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = stemp
j = j + 1
Else
stemp = Sheets("Sheet1").Cells(i, 2).Value
End If
Next i
End Sub