I am looking to extract Unique in the format given on the right side. I found the VBA code on one of the forum site, but this one does not suit me. Is there a way to modify the code or write something better. I do have a formula, but formula is quite resource intensive and a very large excel loads very slowly.
Sub FindDistinctValues()
Dim LastRowFrom As Long
Dim LastRowTo As Long
Dim i As Long, j As Long
Dim temp As Integer
Dim found As Boolean
'determines the last row that contains data in column A
LastRowFrom = Range("A" & Rows.Count).End(xlUp).Row
'Loop for each entry in column A
For i = 2 To LastRowFrom
'get the next value from column A
temp = Range("A" & i).Value
'Determine the last row with data in column B
LastRowTo = Range("B" & Rows.Count).End(xlUp).Row
'initialize j and found
j = 1
found = False
'Loop through "To List" until a match is found or the list has been searched
Do
'check if the value exists in B column
If temp = Range("B" & j).Value Then
found = True
End If
'increment j
j = j + 1
Loop Until found Or j = LastRowTo + 1
'if the value is not already in column B
If Not found Then
Range("B" & j).Value = temp
End If
Next i
End Sub
I didn't test it, but something like this:
Sub FindDistinctValues()
Dim dict As Object, cell As Range
Set dict = CreateObject("Scripting.Dictionary")
For Each cell in Range("A1").CurrentRegion.Resize(, 1)
If Not dict.Exists(cell & "")
cell(, 2) = "Unique"
dict.Add cell & "", 0
End If
Next
End Sub
Related
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
I have excel with 5 different sheets.
sheet3 and sheet4 i want delete rows based on the single column cell value.
in sheet 3 i want to delete rows based on H column cell values if H2="#N/A" and H503="#N/A" then delete entire rows.
in sheet 4 i want to delete rows based on b column cell values if B2="320857876",B3="32085678",B4="12133435" the delete the entire rows where B column cell values starts with 302.
and i want to delete all Data from 'C' column
My excel sheet is like this
Using excel file
Sub Create()
Dim LastRow As Long
Dim i As Long
LastRow = Range("B10000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("B" & i) = "#N/A" Then
Range("B" & i).EntireRow.Delete
End If
Next
End Sub
You've got a few requirements there and your code is fairly light but regarding the #N/A part of it, you can't just test for that text using the value approach, which is the default property returned for a range object.
Sub Create()
Dim LastRow As Long, i As Long
LastRow = Range("B10000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("B" & i).Text = "#N/A" Then
Range("B" & i).EntireRow.Delete
End If
Next
End Sub
... you need to use .Text to get that to work, or, If IsError(Range("B" & i)) Then is another approach.
The rest of your requirements is just logic. The rest of your code is relatively sound so you just need to work through it.
I hope that helps.
Sub delete_rows()
Dim sheet As Worksheet, cell As Range
Count = 1
For Each sheet In ThisWorkbook.Worksheets
If Count = 3 Then
lastrow = sheet.Cells(sheet.Rows.Count, "H").End(xlUp).Row
Set Rng = sheet.Range("H1:H" & lastrow)
For i = Rng.Cells.Count To 1 Step -1
If Application.WorksheetFunction.IsNA(Rng(i).Value) Then
Rng(i).EntireRow.Delete
ElseIf Rng(i).Value = "#NA" Then
Rng(i).EntireRow.Delete
End If
Next
ElseIf Count = 4 Then
lastrow = sheet.Cells(sheet.Rows.Count, "B").End(xlUp).Row
Set Rng = sheet.Range("B1:B" & lastrow)
Debug.Print (Rng(4).Text)
If Rng(2).Value = "320857876" And Rng(3).Value = "32085678" And Rng(4).Value = "12133435" Then
For i = Rng.Cells.Count To 1 Step -1
If Left(Rng(i).Value, 3) = "302" Then
Rng(i).EntireRow.Delete
End If
Next
End If
lastrow = sheet.Cells(sheet.Rows.Count, "C").End(xlUp).Row
Set Rng = sheet.Range("C1:C" & lastrow)
For Each cell In Rng
cell.Value = ""
Next cell
End If
Count = Count + 1
Next
End Sub
This code below does the following:
Copies specific rows from "source" sheet
Pastes the rows in "target" sheet
Does a count of the "types" (Column E) and inserts the count into Column J
The issue I have is by step 3. What the macro is supposed to do is:
Column I, Rows 3 - 5 --> Insert the Column Headings "Defect",
"System", "Script"
Perform a CountIf function of Column E on each of the criteria in
Column I
Output the value (counted number) in Column J, in the respective
rows alongside Column I
For example:
Column I, Row 3 --> Defect
Column J, Row 3 --> Count of the amount of times "Defect" occurs in
Column E
However, what seems to be happening is this:
Column I is populated with the correct criteria
CountIf is performed (what appears to be correctly) and inserts
the values in Column J
As the values are inserted, the criteria in Column I is erased
and all I have left are the number values in Column J
Now if I run the macro a second time, then it performs as expected and I cannot understand why.
Also, there are no "Defect" entries in Column E, so the value is 0. But on the first run, you don't see 0, it's just blank. On the second run, it shows the value 0.
Sub Copy()
Dim xRg As Range, xCell As Range
Dim i As Long, J As Long, K As Long, x As Long, count As Long
Dim y As Workbook
Dim ws1 As Worksheet
Dim element As Variant, myarray As Variant
myarray = Array("Defect", "System", "Script")
i = Worksheets("source").UsedRange.Rows.count
J = Worksheets("target").UsedRange.Rows.count
count = 3
Set y = Workbooks("myWKBK.xlsm")
Set ws1 = y.Sheets("target")
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("target").UsedRange) = 0 Then J = 0
End If
lngLastRow = Cells(Rows.count, "C").End(xlUp).Row
Set xRg = Worksheets("source").Range("E3:E" & lngLastRow & i)
On Error Resume Next
Application.ScreenUpdating = False
With ws1
'Assign name to columns where values will be pasted
.Range("$B$2").Value = "ID"
.Range("$C$2").Value = "Status"
.Range("$D$2").Value = "Description"
.Range("$E$2").Value = "Type"
.Range("$F$2").Value = "Folder"
.Range("$G$2").Value = "Defect ID"
.Range("$I$2").Value = "Type"
.Range("$I$3").Value = "Defect"
.Range("$I$4").Value = "System"
.Range("$I$5").Value = "Script"
.Range("$J$2").Value = "Count"
End With
For Each element In myarray
For K = 1 To xRg.count
If CStr(xRg(K).Value) = element Then
LastRow = ws1.Cells(Rows.count, "B").End(xlUp).Row + 1
xRg(K).EntireRow.Copy Destination:=ws1.Range("A" & LastRow)
J = J + 1
End If
Next
x = Range("E" & Rows.count).End(xlUp).Row
Range("J" & count) = Application.WorksheetFunction.CountIf(Range("E3:E" & x), element)
count = count + 1
Next element
ws1.Columns("B:J").AutoFit
Application.ScreenUpdating = True
End Sub
EDIT:
It's probably well worth mentioning that the below sub on its own works just fine:
Sub CountIf()
Dim element As Variant
Dim myarray As Variant
myarray = Array("Defect", "System", "Script")
Dim count As Long
count = 3
For Each element In myarray
Dim x As Long
x = Range("E" & Rows.count).End(xlUp).Row
Range("J" & count) = Application.WorksheetFunction.CountIf(Range("E3:E" & x), element)
count = count + 1
Next element
End Sub
This function only performs the CountIf on its own and works exactly as expected.
This is a really beautiful part of your code:
Set xRg = Worksheets("source").Range("E3:E" & lngLastRow & i)
It sets correctly the parent worksheet of the Range object, thus VBA knows where to look at. However, for some reasons, it is not always like this. Take a look at these lines:
lngLastRow = Cells(Rows.count, "C").End(xlUp).Row
x = Range("E" & Rows.count).End(xlUp).Row
Range("J" & count) = Application.WorksheetFunction.CountIf(Range("E3:E" & x), element)
where the worksheet is not set. Thus, it takes either the ActiveSheet or the worksheet, in which the code is (if it is in a worksheet and not in a module). Try to rewrite it, following the beautiful part of your code, e.g., defining the worksheet:
With Worksheet("SomeName")
lngLastRow = .Cells(Rows.count, "C").End(xlUp).Row
x = .Range("E" & Rows.count).End(xlUp).Row
.Range("J" & count) = Application.WorksheetFunction.CountIf(Range("E3:E" & x), element)
End With
As a next step to debug, try to remove On Error Resume Next, because it ignores the errors in the applications and may provide false results due to this.
Forgive me, as this may be very simple. I am trying to create a VBA macro that quickly gets statistics from raw data and puts them in a table. The raw data comes in this format:
(They will not always be in groups of three)
How would I get the range for all of a category, and then use that same range for Columns B and C to get the statistics I need?
The below code get you the row numbers of each category and assumes there is no break in content on column B, your question was to get the content of columns C:D by category, having these row values will enable you to code to get the content of C:D.
Public Sub Sample()
Dim WkSht As Worksheet
Dim StrCategory As String
Dim LngRow As Long
Dim LngRowStart As Long
Set WkSht = ThisWorkbook.Worksheets("RawData")
'Take note of the category we are one
StrCategory = WkSht.Range("A" & 2).Value
'Take not of the row the category started on
LngRowStart = 2
'Look to the next row
LngRow = 3
'Loop through the data until column B has no value, signifying the end of the dataset
Do Until WkSht.Range("B" & LngRow) = ""
'Go to the next row until we are given a new category or make it to the end of the dataset
Do Until (WkSht.Range("A" & LngRow) <> "") Or (WkSht.Range("B" & LngRow) = "")
LngRow = LngRow + 1
Loop
'Talk in the immediate pane
Debug.Print StrCategory & " is on rows " & LngRowStart & " to " & LngRow - 1
'Get the next values
StrCategory = WkSht.Range("A" & LngRow)
LngRowStart = LngRow
'Move on
LngRow = LngRow + 1
Loop
Set WkSht = Nothing
End Sub
Below is the input data I gave it: -
Below is the output from the code: -
You could use some If statements and pull this all into an array, but it seems more direct to just fill in the blanks
Sub FillColA()
Dim LastRow As Long
LastRow = Application.WorksheetFunction.CountA(Range("B:B"))
Range("A2:A" & LastRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
End Sub