I'm trying to fill a combobox with cells from column A that contain #. I get an error message: "Couldn't find specific object." Please help me understand what I'm missing here. Thank you.
Dim i As Long
Dim lr As Long
Sheets("Colon").Select
lr = Worksheets("Colon").Cells(Rows.count, "A").End(xlUp).Row
For i = 2 To lr
If InStr(Cells(i, 1).Value, "#") > 0 Then
ComboBox1.List = Worksheets(1).Range("A2:A" & lr).Value
UserForm1.Controls("ComboBox" & i).Object.List = ComboBox1.List
End If
Next i
Here, I got one for you. Try with this.
Public Sub fillCombo()
Dim row, lastRow, index As Long
Dim dataList() As String
'Data list index
index = 0
'Getting the last row
lastRow = Sheets("Colon").Cells(Rows.Count, "A").End(xlUp).row
'Looping all row from row 2.
For row = 2 To lastRow
'Here, my logic is some cell value which not include "#" are not store in array.
'If "#" is include in cell value.
If InStr(Cells(row, 1).Value, "#") > 0 Then
'Increase index
index = index + 1
'Re-declare dataList size
ReDim Preserve dataList(index)
'Store cell value in array
dataList(index) = Cells(row, 1).Value
End If
Next row
'Set dataList to combo box.
Sheets("Colon").ComboBox1.List = dataList
End Sub
Related
I am working on a dynamic worksheet which the total rows and columns of content will be changing.
What I try to do is, making an active cell going through the worksheet. It starts from the very last column that has content (I used UsedRange here), and from the 7st row down to the last row not blank.
When 1) The active cell has a color filling of index 16 or 36; 2) The active cell has no value, the cell will fetch the value storing in the matching row E.
The loop will end when hitting column E (I haven't been able to go that far yet).
I will attach my code below for all possible help, since it complies but does not return any result...Thank you again!
Sub catchCurrentAutomated()
Dim column As Integer
Dim row As Integer
Dim Cell As Range
row = 7
column = ActiveSheet.UsedRange.Columns.Count
Set Cell = ActiveCell
While range("A" & row) <> ""
If Cell.Interior.ColorIndex = 16 And _
IsEmpty(Cell.Value) = True Then
Cell.Value = Cells(ActiveCell.row, "E").Value
ElseIf Cell.Interior.ColorIndex = 36 And _
IsEmpty(Cell.Value) = True Then
Cell.Value = Cells(ActiveCell.row, "E").Value
End If
row = row + 1
column = column - 1
Wend
End Sub
Something like this should work (untested)
Sub catchCurrentAutomated()
Dim col As Long '<< use Long not Integer
Dim row As Long
Dim c As Range, ws As Worksheet, lr As Long, indx
Set ws = ActiveSheet
col = ws.UsedRange.Columns.Count
lr = ws.Cells(Rows.Count, 1).End(xlUp).row 'last occupied cell in ColA
Do While col > 5
For row = 7 To lr
With ws.Cells(row, col)
indx = .Interior.Color.Index
If (indx = 16 Or indx = 36) And Len(.Value) = 0 Then
.Value = ws.Cells(row, "E").Value
End If
End With
Next row
col = col - 1 'next column to left
Loop
End Sub
I have the following excel
I am trying the following code
> Sub fill_blanks()
Dim i As Long
i = 2 '
Do Until Range("B" & i) = ""
Range("B" & i).Select
If ActiveCell.FormulaR1C1 <> "" Then
Range("A" & i).Select
If ActiveCell.FormulaR1C1 = "" Then
Range("A" & i - 1).Copy
Range("A" & i).PasteSpecial Paste:=xlPasteValues
Else
i = i + 1
End If
Else
i = i + 1
End If
Loop
End Sub >
What I need to check is if the cell is not empty, then to keep its value, and if it was empty to check the first next not empty cell and the previous non empty cell in the same column, and if they have the same value, then to fill all the empty cells between with the same value, and if the two cells are not matching, then to return X.
So the result will be as following
But using the code , I am getting something different.
This what I get with this code
Find the last used row LastRow so we know where to stop.
Loop through your rows, when you come accross an epmty cell remember it FirstEmptyRow
Keep looping until you find data again, the row before is then LastEpmtyRow. Now we know the beginning and the end of the empty space.
Check if above the epmty space and below the empty space is the same date. If so fill it into the empty space otherwise fill in x.
So you end up with something like
Option Explicit
Public Sub FillData()
Const START_ROW As Long = 2 'define first data row
Const COL As String = "A" 'define the column
Dim ws As Worksheet 'define your worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long 'find last used row in column A
LastRow = ws.Cells(ws.Rows.Count, COL).End(xlUp).Row
Dim FirstEmptyRow As Long, LastEpmtyRow As Long 'first and last empty row of a empty range
Dim iRow As Long
For iRow = START_ROW To LastRow
If ws.Cells(iRow, COL).Value = vbNullString And FirstEmptyRow = 0 Then
'found first row of an empty range
FirstEmptyRow = iRow
ElseIf ws.Cells(iRow, COL).Value <> vbNullString And FirstEmptyRow <> 0 Then
'found last row of an empty range
LastEpmtyRow = iRow - 1
'check if same date to fill either the date or x
If ws.Cells(FirstEmptyRow - 1, COL).Value = ws.Cells(LastEpmtyRow + 1, COL).Value Then
'fill date
ws.Range(ws.Cells(FirstEmptyRow, COL), ws.Cells(LastEpmtyRow, COL)).Value = ws.Cells(FirstEmptyRow - 1, COL).Value
Else
'fill x
ws.Range(ws.Cells(FirstEmptyRow, COL), ws.Cells(LastEpmtyRow, COL)).Value = "x"
End If
'reset variables
FirstEmptyRow = 0
LastEpmtyRow = 0
End If
Next iRow
End Sub
Image 1: Illustration of the process.
Currently, I want to automate some annoying work in excel and need some help.
I have a huge report which has 200k+ rows and about 500 columns and my task is to find out which cells of a column are never used.
This was fairly easy and I managed it to create a script that works for that so far.
But now I want to distinguish between row types and return for each row type whether there are columns that are never used.
My problem is that I do not know how to iterate through the contents of a cell, so that if the row type changes my script will count the empty columns for the next row type.
I hope you get the idea and can help me. You do not have to give me the full code but maybe an idea of how I can get to the solution :)
This is the vba code I currently have and that gives me the correct solution but without distinguishing between the rowtypes
Public row As Long
Public rowMax As Long
Public startRow As Integer
Public materialType As String
Public filter As String
Public col As Integer
Public colMax As Integer
Public isUsed As Boolean
Sub bestimmeObFelderGenutzt()
With Sheets("Sheet1")
filter = "I"
startRow = 2
rowMax = Sheets("Sheet1").Cells(.Rows.Count, "F").End(xlUp).row
colMax = Sheets("Sheet1").Cells(1, .Columns.Count).End(xlToLeft).Column
materialType = Sheets("Sheet1").Range(filter & startRow).Value
For col = 1 To colMax
Sheets("Sheet2").Cells(1, col + 2).Value = Sheets("Sheet1").Cells(1, col).Value
Next col
For row = 2 To rowMax
Sheets("Sheet2").Range("A" & row).Value = Sheets("Sheet1").Range("A" & row).Value
Sheets("Sheet2").Range("B" & row).Value = Sheets("Sheet1").Range("I" & row).Value
For col = 1 To colMax
If IsEmpty(Sheets("Sheet1").Cells(row, col)) = False Then
isUsed = True
Sheets("Sheet2").Cells(row, col + 2).Value = 1
Else:
Sheets("Sheet2").Cells(row, col + 2).Value = 0
End If
Next col
Next row
End With
End Sub
Sub findeUngenutzteSpalten()
With Sheets("Sheet2")
rowMax = Sheets("Sheet2").Cells(.Rows.Count, "F").End(xlUp).row
colMax = Sheets("Sheet2").Cells(1, .Columns.Count).End(xlToLeft).Column
Sheets("Sheet3").Cells(1, 1).Value = "Spaltenüberschrift"
Sheets("Sheet3").Cells(1, 2).Value = "Jemals benutzt?"
For col = 3 To colMax
isUsed = False
For row = 2 To rowMax
If Sheets("Sheet2").Cells(row, col).Value = 1 Then
Sheets("Sheet3").Range("A" & col - 1).Value = Sheets("Sheet2").Cells(1, col).Value
Sheets("Sheet3").Range("B" & col - 1).Value = "Ja"
GoTo WeiterCol
Else:
If row = rowMax Then
Sheets("Sheet3").Range("A" & col - 1).Value = Sheets("Sheet2").Cells(1, col).Value
Sheets("Sheet3").Range("B" & col - 1).Value = "Nein"
Else:
GoTo WeiterRow
End If
End If
WeiterRow:
Next row
WeiterCol:
Next col
End With
End Sub
If I understood your task correctly this should work, copy to your module and read comments:
Sub FindUnusedColumnsPerRow()
Dim cellRow As range, cellColumn As range
Dim rowRange As range, columnRange As range
Dim rowsCount As Long, columnsCount As Long
Dim insertRow As Long
Dim listOfEmptyColumns()
Dim i As Long, j As Long
Dim arrayCheck As Integer
With Sheets("Sheet1") ' I assume that this is your sheet with materials where you want to find unused columns
rowsCount = .Cells(Rows.Count, 6).End(xlUp).row ' get last row
columnsCount = .Cells(1, Columns.Count).End(xlToLeft).Column ' get last column
For Each cellRow In range(.Cells(2, 1), .Cells(rowsCount, 1)) ' going through all rows - here I suppose that material type is in the 1-st column, 1-st row is a header and data starts from 2-d row
For Each cellColumn In range(.Cells(cellRow.row, 2), .Cells(cellRow.row, columnsCount)) ' for each row looking through all columns - I suppose that data starts from 2-d column
If cellColumn = "" Then ' if the cell is empty.
ReDim Preserve listOfEmptyColumns(i) ' expanding array when needed
listOfEmptyColumns(i) = cellColumn.Column ' adding column number to an array, you may change it to = .cells(1,cellColumn.Column) to put a header name instead of column number
i = i + 1 ' increment the counter
End If
Next
On Error Resume Next ' a small trick to check whether the array with column numbers is empty
arrayCheck = UBound(listOfEmptyColumns) ' if the array is empty - an #9 "Subscript out of range" exception will be thrown
If Err.Number = 0 Then ' error number is 0 - means that there was no error
With Sheets("Sheet2") ' I suppose this is the sheet to store results
insertRow = .Cells(Rows.Count, 1).End(xlUp).row + 1 ' find the row to insert
.Cells(insertRow, 1) = cellRow.Value ' put the type to 1-st column
j = 2 ' start filling the row of the type with numbers of empty columns
For i = 0 To UBound(listOfEmptyColumns) ' populating data from array
.Cells(insertRow, j) = listOfEmptyColumns(i)
j = j + 1
Next
End With
End If
Err.Clear ' clearing the error, because it still holding an error information (if it was thrown)
On Error GoTo 0 ' don't forget to switch on normal error handling
Erase listOfEmptyColumns ' reset array before next row as the data is stored on sheet2
i = 0 ' reset the counter for further use
Next
End With
End Sub
friends I have Two Excel Sheets which is shown below...
**Sheet_1** **Sheet_2**
ID Name Address ID Name Address
1 A Any 2 B Any
2 B Any 4 D Any
3 C Any 5 E Any
4 D Any
5 E Any
I want to delete all rows from Sheet_1 which is not in Sheet_2.
Note: ID of sheets is unique
I'm not sure if I got this right, but you want to delete rows that are not in Sheet2?
So that would make your Sheet1 to be a copy of Sheet2, wouldn't it?
Well, anyways, here is the code of the main Sub:
Sub Main()
Set idsToExclude = CreateObject("Scripting.Dictionary"): idsToExclude.CompareMode = TextCompare
'fill dictionary with IDs from sheet 2
Set idsToExclude = CreateDictFromColumns("Sheet2", "A", "B")
'find last populated row
xEndRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'iterate all rows from bottom to top
For i = xEndRow To 2 Step -1
'get value of cell at current row and 1st column
currentCellValue = ActiveSheet.Cells(i, 1).Value
'if row doesnt met criteria, delete it
If Not idsToExclude.Exists(currentCellValue) Then
Rows(i).Delete
End If
Next
End Sub
And the Function to get the Ids and names from a specific Sheet:
Function CreateDictFromColumns(sheet As String, keyCol As String, valCol As String) As Object
Set dict = CreateObject("Scripting.Dictionary"): dict.CompareMode = TextCompare
Dim rng As Range
Dim i As Long
Dim lastCol As Long '// for non-adjacent ("A:ZZ")
Dim lastRow As Long
lastRow = Sheets(sheet).Range(keyCol & Sheets(sheet).Rows.Count).End(xlUp).Row
Set rng = Sheets(sheet).Range(keyCol & "1:" & valCol & lastRow)
lastCol = rng.Columns.Count
For i = 2 To lastRow
If (rng(i, 1).Value = "") Then Exit Function
dict.Add rng(i, 1).Value, rng(i, lastCol).Value
Next
Set CreateDictFromColumns = dict
End Function
Note: If you want to make the contrary (delete IDs in Sheet1 that are in Sheet2), just remove the Not Operator from the following line:
If Not idsToExclude.Exists(currentCellValue) Then
As you can see, some parts are hard-coded. My suggestion is to adapt those parts and make it more dynamical, I had to write it like that due to lack of details in question.
I have column A that has all existing categories, new categories are listed in column C. I'm trying to determine how to take these new categories, and add them to column "a" if they aren't already in column A. In the example the new categories in column C are added to column A even if there are already in column A. I would also need range("a1") in the if-then line to be a dynamic range since new categories will be added as the code runs. Some constructive criticism would be greatly appreciated as well to help me in the future.
Sub newcategory()
Dim newcatcount As Integer
Dim i As Integer
newcat = Range("c100000").End(xlUp).Row
For i = 1 To newcat
If Cells(i, 3).Value <> Range("a1") Then
Cells(i, 3).Select
Selection.copy
Range("a100000").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
Please give this a try...
Sub AddNewCategories()
Dim lrA As Long, lrC As Long, i As Long, j As Long
Dim x, y, z(), dict
lrA = Cells(Rows.Count, 1).End(xlUp).Row
lrC = Cells(Rows.Count, 3).End(xlUp).Row
'Array to hold the categories in column A starting from Row1, assuming the categories start from A1. If not, change it accordingly.
x = Range("A1:A" & lrA).Value
'Array to hold the new categories in column C starting from Row1, assuming the categories start from C1. If not, change it accordingly.
y = Range("C1:C" & lrC).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = ""
Next i
For i = 1 To UBound(y, 1)
If Not dict.exists(y(i, 1)) Then
dict.Item(y(i, 1)) = ""
j = j + 1
ReDim Preserve z(1 To j)
z(j) = y(i, 1)
End If
Next i
If j > 0 Then
Range("A" & lrA + 1).Resize(j).Value = Application.Transpose(z)
End If
Set dict = Nothing
End Sub
you could use excel built in RemoveDuplicates() function, as follows (mind the comments):
Option Explicit
Sub newcategory()
Dim newcat As Range
With Worksheets("Categories") ' change "Categories" to your actual sheeet name
Set newcat = .Range("C1", .Cells(.Rows.Count, 3).End(xlUp)) ' get the range of all nwe categories in reference sheet column C from row 1 down to last not empty one
.Cells(.Rows.Count, 1).End(xlUp).Resize(newcat.Rows.Count).Value = newcat.Value ' append new categories values below existing categories in column A
.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).RemoveDuplicates Columns:=Array(1), Header:=xlNo ' remove duplicates
End With
End Sub