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
Related
I have a table with information in column A and an appropriate value in column B. I want to write a macro that inserts a new row for each "Person" in dependence of the value in column B and copies the original information into that row, which for example means that in the end there are 5 rows with "Person A", 2 rows for "Person B" etc.
original table:
result:
My first approach looks like that. It doesn't work.
Dim i, j, k As Integer
For i = Range("A" & Range("A:A").Rows.Count).End(xlUp).Row To 1 Step -1
For j = 1 To Range("B" & i)
Rows(i).Select
Selection.Insert Shift:=xlDown
k = k + j
Range(Cells(k, 1), Cells(k, 2)).Copy Destination:=Range("A" & i)
Next j
Next i
This would work for you, changing the number of inserts based on value in column B:
Option Explicit
Sub test()
With Sheets(1)
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = lastRow To 1 Step -1
If IsNumeric(.Cells(i, 2).Value) = True Then
Dim numberOfInserts As Long
numberOfInserts = .Cells(i, 2).Value - 1
If numberOfInserts > 0 Then
Dim insertCount As Long
For insertCount = 1 To numberOfInserts
.Rows(i).Copy
.Rows(i).Insert
Next insertCount
End If
End If
Next i
End With
End Sub
First we check that you're dealing with numbers. Second you have a single line already, so number -1, then that this number is >0. Lastly, you insert via a loop which does the counting for you.
Test data:
Output after running:
Your index calculation is messed up. Use the debugger, step thru the code (F8) and notice what happens:
a) Your Select/Insert-construct creates a new row above the row you want to copy, not below.
b) Your calculation of index k fails: You are not initializing k, so it starts with value 0. Than you add j (1..3) to k, resulting in values 1, 3, 6, and copy data from that line.
I would suggest you take a different approach: Copy the original data into an array and then loop over that array. This avoids multiple Select, Copy and Insert statements (that are slow) and allow to copy the data from top to bottom.
Sub copy()
Dim rowCount As Long
Dim data As Variant
With ActiveSheet ' Replace with the sheet you want to work with
' Copy the current table into array
rowCount = .Cells(.Rows.Count, 1).End(xlUp).row
data = .Range(.Cells(1, 1), .Cells(rowCount, 2))
Dim oldRow As Long, newRow As Long
newRow = 1
' Loop over old data
For oldRow = 1 To rowCount
Dim repeatCount As Long
repeatCount = Val(data(oldRow, 2)) ' We want to have so many occurrences of the row
if repeatCount <= 0 Then repeatCount=1
Dim col As Long
' Create "repeatCount" rows of data (copy column by column)
For col = 1 To 2
.Cells(newRow, col).Resize(repeatCount, 1) = data(oldRow, col)
Next col
newRow = newRow + repeatCount
Next
End With
End Sub
I'm using a for loop but I'm open suggestions if there's a better way to separate the data!
I want to insert two new rows whenever the integer in Column 11 or "K" changes. Column K represents groups of data and each is named with integers between 1 and 10 (inclusive). Each group varies in size, hence why I wanted a for loop to check each time the group increments to trigger the insertion of the rows.
For example:
From the data below two blank rows should be inserted below K11 and below K18. This will result in the data being separated by two blank rows whenever two groups were 'touching' each other.
K2 = 1, K3 = 1, K4 = 1 ... K11 = 1
K12 = 2, K13 = 2, K14 = 2... K18 = 2
K19 = 3, K20 = 3 ...
I've put together the following for loop but it inserts 500 (the counter limit) rows after the first group and no row inserts for the remaining groups. Can you explain why this happens and how I can work around this?
Dim LCounter As Integer
For LCounter = 2 To 500
If Cells(LCounter + 1, 11).Value <> Cells(LCounter, 11) Then
Rows(LCounter + 1).Insert shift:=xlShiftDown
End If
Next LCounter
Try this way, please. It should be very fast even for big ranges:
Sub SeparateGroupsByEmptyRows()
Dim LCounter As Long, col As Long, rng As Range
col = 11
For LCounter = 2 To 500
If cells(LCounter + 1, col).Value <> cells(LCounter, col).Value Then
If rng Is Nothing Then
Set rng = cells(LCounter + 1, col)
Else
Set rng = Union(rng, cells(LCounter + 1, col))
End If
End If
Next LCounter
'For the case of two or more consecutive groups of only one row each:
If InStr(rng.Address(0, 0), ":") > 0 Then Set rng = makeDiscontinuu(rng)
rng.EntireRow.Insert Shift:=xlDown
End Sub
Function makeDiscontinuu(rng As Range) As Range
Dim A As Range, c As Range, strAddress As String
For Each A In rng.Areas
If A.cells.count = 1 Then
strAddress = strAddress & A.Address(0, 0) & ","
Else
For Each c In A.cells
strAddress = strAddress & c.Address(0, 0) & ","
Next c
End If
Next A
Set makeDiscontinuu = Range(left(strAddress, Len(strAddress) - 1))
End Function
try this, should be one empty row separation (not tested)
Dim LCounter As Integer, lcEnd as integer: lcEnd =500
For LCounter = 2 To lcEnd
If Cells(LCounter + 1, 11).Value <> Cells(LCounter, 11) and Cells(LCounter + 1, 11)<> "" Then
Rows(LCounter + 1).Insert shift:=xlShiftDown
lcEnd =lcEnd +1
End If
Next LCounter
Insert Rows Before Change of Cell Value
The first procedure uses For...Next to solve the problem by looping backwards.
The second procedure uses Do...Loop illustrating the complications when looping forwards.
The Code
Option Explicit
Sub insertBeforeChangeForNext()
Const iRows As Long = 2 ' Number of Rows to Insert
Const cCol As Long = 11 ' Criteria Column
Const fRow As Long = 2 ' First Row
' Either...
Const lRow As Long = 500 ' Last Row
' ...or rather determine the last non-empty row:
'Dim lRow As Long: lRow = Cells(Rows.Count, cCol).End(xlUp).Row ' LR
If lRow <= fRow Then
Exit Sub
End If
Application.ScreenUpdating = False
Dim LCounter As Long ' Rows Counter
For LCounter = lRow - 1 To fRow Step -1
If Cells(LCounter + 1, cCol).Value <> Cells(LCounter, cCol).Value Then
Rows(LCounter + 1).Resize(iRows).Insert
End If
Next LCounter
Application.ScreenUpdating = True
End Sub
Sub insertBeforeChangeDoLoop()
Const iRows As Long = 2 ' Number of Rows to Insert
Const cCol As Long = 11 ' Criteria Column
Const fRow As Long = 2 ' First Row
' Either...
Const lRow As Long = 500 ' Initial Last Row
' ...or rather determine the last non-empty row:
'Dim lRow As Long: lRow = Cells(Rows.Count, cCol).End(xlUp).Row ' ILR
Dim Current As Long: Current = fRow ' Current Row
Dim Last As Long: Last = lRow ' Current Last Row
Application.ScreenUpdating = False
Do While Current < Last
If Cells(Current + 1, cCol).Value <> Cells(Current, cCol).Value Then
Rows(Current + 1).Resize(iRows).Insert
Last = Last + iRows
Current = Current + iRows
End If
Current = Current + 1
Loop
Application.ScreenUpdating = True
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.
At a high level I am trying to set a cell equal to a random cell within a range. The issue I am having is that in this range I want to pull a random Value from, the Value I am taking is the result of an 'if' expression that either sets the cell to a Value or "". So when I chose the random value I only want to choose cells that have an actual value, not the "".
Does anyone know how to get this expected behavior?
The code below shows what I have tried currently, each large block is commented to help with understanding. The block I need help with replaces the values in each column until the next cell is blank then moves to the next column.
upperBound = 1798
lowerBound = 2
Randomize
'This loop section populates the data area with a static value in cell 9,3 then 9,4 etc..
For j = 3 To 15
val = Cells(9, j).Value
For i = 1 To val
Cells(12 + i, j).Value = Cells(9, j)
Next i
Next j
'This loop section uses the cells already populated down each column and replaces that value with the random value from the other range
Dim x As Integer
' Set numrows = number of rows of data.
For j = 3 To 15
NumRows = Range(Cells(13, j), Cells(13, j).End(xlDown)).Rows.Count
' Select cell 13,j.
Cells(13, j).Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
ActiveCell.Value = Worksheets("2017 Role IDs").Cells(Int((upperBound - lowerBound + 1) * Rnd + lowerBound), 2).Value
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
Next j
This is the data before the second block runs. I want to replace the values that just match the number in the second row with the random number in the range:
This is what I would like to look like:
But currently it looks like this because the random selector is taking blank values:
Something like this should work for you:
Sub tgr()
Dim wb As Workbook
Dim wsNums As Worksheet
Dim wsDest As Worksheet
Dim aData As Variant
Dim vData As Variant
Dim aNums() As Double
Dim aResults() As Variant
Dim lNumCount As Long
Dim lMaxRows As Long
Dim lRowCount As Long
Dim ixNum As Long
Dim ixResult As Long
Dim ixCol As Long
Set wb = ActiveWorkbook
Set wsNums = wb.Worksheets("2017 Role IDs")
Set wsDest = wb.ActiveSheet
With wsNums.Range("B2", wsNums.Cells(wsNums.Rows.Count, "B").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
lNumCount = WorksheetFunction.Count(.Cells)
If lNumCount = 0 Then Exit Sub 'No numbers
ReDim aNums(1 To lNumCount)
If .Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = .Value
Else
aData = .Value
End If
'Load populated numeric cells into the aNums array
For Each vData In aData
If Len(vData) > 0 And IsNumeric(vData) Then
ixNum = ixNum + 1
aNums(ixNum) = vData
End If
Next vData
End With
lMaxRows = Application.Max(wsDest.Range("C9:O9"))
If lMaxRows = 0 Then Exit Sub 'Row count not populated in row 9 for each column
ReDim aResults(1 To WorksheetFunction.Max(wsDest.Range("C9:O9")), 1 To 13)
'Populate each column accordingly and pull a random number from aNums
For ixCol = 1 To UBound(aResults, 2)
If IsNumeric(wsDest.Cells(9, ixCol + 2).Value) Then
For ixResult = 1 To CLng(wsDest.Cells(9, ixCol + 2).Value)
Randomize
aResults(ixResult, ixCol) = aNums(Int(Rnd() * lNumCount) + 1)
Next ixResult
End If
Next ixCol
wsDest.Range("C13").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub
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