What is the best way to achieve the requirement from the sample data as per the screenshot attached? I want to merge the RED highlighted font in one row & delete the additional Row. Example - Data in row 4, 6 & 8 can move to the previous column & then 4, 6 & 8 rows should be completely deleted.
Note: there is no consistency in data the inconsistency of data may very between ROWS like B4, C6 & A8.
Delete Entire Rows With Condition
Loops through the rows from the bottom to the top.
If there is at least one blank cell, returns the value of each cell adjacent to the top of each non-blank cell, concatenated with the value of the non-blank cell, in the adjacent cell. Then it combines the first cell of the row into a range.
Deletes the entire rows of the combined range.
Option Explicit
Sub ConcatMissing()
Const SecondDataRowFirstCellAddress As String = "A4"
Const Delimiter As String = ""
Dim ws As Worksheet: Set ws = ActiveSheet
Dim fCell As Range: Set fCell = ws.Range(SecondDataRowFirstCellAddress)
Dim rg As Range
With fCell.CurrentRegion
Set rg = fCell.Resize(.Row + .Rows.Count _
- fCell.Row, .Column + .Columns.Count - fCell.Column)
End With
Dim cCount As Long: cCount = rg.Columns.Count
Dim rrg As Range
Dim rCell As Range
Dim drg As Range
Dim SkipRow As Boolean
Dim r As Long
For r = rg.Rows.Count To 1 Step -1
Set rrg = rg.Rows(r)
If Application.CountBlank(rrg) > 0 Then
For Each rCell In rrg.Cells
If Len(CStr(rCell.Value)) > 0 Then
rCell.Offset(-1).Value = CStr(rCell.Offset(-1).Value) _
& Delimiter & CStr(rCell.Value)
End If
Next rCell
If drg Is Nothing Then
Set drg = rrg.Cells(1)
Else
Set drg = Union(drg, rrg.Cells(1))
End If
End If
Next r
If drg Is Nothing Then Exit Sub
drg.EntireRow.Delete
End Sub
Related
I have a question regarding the below picture, I need to check until the end of the columns.
the check always begins from column "L" but the end change from file to file how needed check.
The below code work very well, still only this small issue, Your help will be appreciated
Sub HighlightInvalidRows()
Application.ScreenUpdating = False
Dim i As Long
Dim c As Long
' Prepare.
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets("Cumulated BOM")
' Reference the range ('rg').
Dim rg As Range
Set rg = ws.Range("L2", "S" & ws.Cells(ws.Rows.Count, "L").End(xlUp).Row)
' Write the number of columns of the range to a variable ('CellsCount').
Dim CellsCount As Long: CellsCount = rg.Columns.Count
' Each row of the range has this number of columns (cells).
' Remove all range colors.
rg.Interior.Color = xlNone
' Combine the rows ('rrg') to be highlighted
' into the Highlight range ('hrg').
' Declare variables that appear for the first time in the following loop.
Dim hrg As Range
Dim rrg As Range
Dim MatchCount As Long
' Loop through the rows of the range.
For Each rrg In rg.Rows
' Write the number of appearances of the value in the current row
' to a variable ('MatchCount').
MatchCount = Application.CountIf(rrg, "-") Or Application.CountIf(rrg, "")
' Compare the match count with the cells count.
If MatchCount = CellsCount Then ' the numbers are equal
' Combine the current row into the highlight range.
If hrg Is Nothing Then ' the first match
Set hrg = rrg
Else ' all other matches
Set hrg = Union(hrg, rrg)
End If
End If
Next rrg
' Highlight the rows (in one go) and inform.
If hrg Is Nothing Then ' no matches found
MsgBox "No Empty Penetration Found.", vbInformation
Else ' matches found
hrg.Interior.Color = RGB(255, 87, 87)
End If
You define the Range with this statement:
Set rg = ws.Range("L2", "S" & ws.Cells(ws.Rows.Count, "L").End(xlUp).Row)
You fetch the number of rows but hardcode the end column ("S").
There is a question here on SO about how to get the last used row/column/cell in Excel using VBA. Depending on the circumstances, it can get quite tricky, see Find last used cell in Excel VBA.
However, there are two things that you can easily try:
a) Simply use CurrentRegion:
Set rg = ws.Range("L2").CurrentRegion
b) The technique that is used most often to fetch the last row is the logic to "jump" to the last row and then jump back to the last row that is used. Think about as if you jump to the very end of your sheet by pressing Ctrl+Down and then pressing Ctrl+Up. Your code does already exactly that.
Similarly, you can get the last column by pressing Ctrl+Right and then pressing Ctrl+Left.
In Code this could look like that:
Dim lastRow As Long, lastCol As Long
With ws
lastRow = .Cells(.Rows.Count, "L").End(xlUp).Row ' Last row in use in Col L
lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column ' Last Col in use in row 2
Set rg = .Range(.cells(2, "L"), .cells(lastRow, lastCol))
End With
Reference a Part of a (Table) Range
Note that the code is written for any range and you are having problems only with referencing the range dynamically.
There are several ways to do this but I'll stick with the easiest, most commonly used way, described in more detail in FunThomas' answer.
Replace the following lines...
' Reference the range ('rg').
Dim rg As Range
Set rg = ws.Range("L2", "S" & ws.Cells(ws.Rows.Count, "L").End(xlUp).Row)
... with these:
' In column 'L', determine the last row ('lRow'),
' the row of the bottom-most non-empty cell.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row
' In row '1' (where the headers are), determine the last column ('lCol'),
' the column of the right-most non-empty cell.
Dim lCol As Long: lCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
' Reference the range ('rg').
Dim rg As Range: Set rg = ws.Range("L2", ws.Cells(lRow, lCol))
How can I auto fill a column down, e.g., Cell(A1).value = dog and Cell(A12).value = Pen
How do I fill down A2:A11 with the value = dog and the A13 value = pen without manually selecting the column?
Sub filldown_example()
Dim missingcells as range
Dim fillsedcells as range
Set missingcells = select
For each filledcells in missingcells
If filledcells = "" Then
filledcells.filldown
End If
Next filledcells
End sub
No need to loop here.
Sub fillit()
With Range("a1:a13")
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value 'formula to value
End With
End Sub
You do not need VBA for this. If you search Google for Excel fill all blanks with cell above you will get the non-VBA method.
If you still want VBA, then try this. You do not need to loop through all cells.
Code:
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim rng As Range
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find the last row in Col A and add 1 to it
lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
'~~> Find the blank cells
On Error Resume Next
Set rng = .Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
'~~> Add the formula to get values from the above cell in 1 go
If Not rng Is Nothing Then rng.FormulaR1C1 = "=R[-1]C"
'~~> Convert formulas to values
.Range("A1:A" & lRow).Value = .Range("A1:A" & lRow).Value
End With
End Sub
In Action:
Fill Down Selection
This will allow you to select multiple ranges with multiple columns to fill down each of them.
Range
Sub FillDownSelectionRange()
If TypeName(Selection) <> "Range" Then Exit Sub
Dim rg As Range: Set rg = Selection
Dim arg As Range ' Area Range
Dim crg As Range ' Column Range
Dim rCell As Range ' Row Cell Range
Dim rValue As Variant
For Each arg In rg.Areas
For Each crg In arg.Columns
If crg.Rows.Count > 1 Then
For Each rCell In crg.Cells
If Len(CStr(rCell.Value)) = 0 Then
rCell.Value = rValue
Else
If rCell.Value <> rValue Then
rValue = rCell.Value
End If
End If
Next rCell
End If
rValue = Empty
Next crg
Next arg
End Sub
Array
To speed up, instead of looping through the cells, you could loop through an array.
Sub FillDownSelectionArray()
If TypeName(Selection) <> "Range" Then Exit Sub
Dim rg As Range: Set rg = Selection
Dim arg As Range ' Area Range
Dim crg As Range ' Column Range
Dim cData As Variant ' Column Array
Dim rValue As Variant
Dim r As Long
For Each arg In rg.Areas
For Each crg In arg.Columns
If crg.Rows.Count > 1 Then
cData = crg.Value
For r = 1 To UBound(cData, 1)
If IsEmpty(cData(r, 1)) Then
cData(r, 1) = rValue
Else
If cData(r, 1) <> rValue Then
rValue = cData(r, 1)
End If
End If
Next r
crg.Value = cData
End If
rValue = Empty
Next crg
Next arg
End Sub
I need some help. I have two columns: A and B. Column A and Column B have the following headers "Status" and "State". A filter has been applied to select "down" from a choice of "up" and "down" in Column A. When Column A is filtered some blank cells are revealed in Column B after some cells in Column B is cleared. The amount of data in the sheet varies and the position of these blanks also vary. I will like to fill down these blank cells in Column B using the values in visible cells only (not from the values in the hidden cells). Can someone help me edit this code?
In the pic above SO will fill down from 50476 to 50492 without erasing the values in the hidden cells.
Sub Filldownvisiblecells ()
Dim ws as worksheet
Dim dl as long
Dim rg as range
ws = Workbooks("Book1.xlsm"). Worksheets("Sheet1")
dl = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'Filter Column A by Down
ws.Range("A1").AutoFilter Field:=1, Criteria1:="Down"
'Clearing States in Column B (This action generates blanks that I will like to filldown from visible cells NOT hidden cells)
ws.Range("B2:B" & dl).SpecialCells(xlCellTypeVisible).Select
For Each rg In Selection.Cells
If rg.Text = "R1" Or rg.Text = "R2" Or rg.Text = "UT" Then
rg.ClearContents
End If
Next rg
'Select Filldown Range in Column B
ws.Range("B2:B" & dl). SpecialCells(xlCellTypeVisible).Select
'Filldown Blanks in Column X
For Each rg In Selection.Cells
If rg.Value = "" Then
rg.FillDown
End If
Next rg
End Sub
Fill Down With Visible Cells' Values (AutoFilter)
Option Explicit
Sub FillDownVisible()
Const wsName As String = "Sheet1"
Const fRow As Long = 1 ' First Row
Const fCol As String = "A" ' Filter Column
Const fCriteria As String = "Down" ' Filter Criteria
Const dCol As String = "B" ' Destination Column
Dim ws As Worksheet
' The Workbook Containing This Code ('ThisWorkbook')
Set ws = ThisWorkbook.Worksheets(wsName)
' An Open Workbook
'Set ws = Workbooks("Book1.xlsm").Wordksheets(wsname)
' Possibly Closed Workbook (Needs the Full File Path)
'Set ws = Workbooks.Open("C:\Test\Book1.xlsm").Worksheets(wsName)
' Clear possible previous ('active') filter.
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
' Create a reference to the Filter Range ('frg').
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, fCol).End(xlUp).Row
Dim frg As Range: Set frg = ws.Cells(fRow, fCol).Resize(lRow - fRow + 1)
' Create a reference to the Destination Data Range (no headers).
Dim ddrg As Range: Set ddrg = frg.EntireRow.Columns(dCol) _
.Resize(frg.Rows.Count - 1).Offset(1)
' Filter Filter Range.
frg.AutoFilter Field:=1, Criteria1:=fCriteria
' Create a reference to the Destination Range ('drg').
Dim drg As Range: Set drg = ddrg.SpecialCells(xlCellTypeVisible)
Dim dCell As Range ' Current Destination Cell
Dim pValue As Variant ' Previous Value
Dim cValue As Variant ' Current Value
' Loop through the cells of the Destination Range.
For Each dCell In drg.Cells
cValue = dCell.Value
Select Case UCase(CStr(cValue))
Case "R1", "R2", "UT", ""
dCell.Value = pValue
Case Else
pValue = cValue
End Select
Next dCell
ws.AutoFilterMode = False
End Sub
There are 3 groups (A,B,C) of data in excel sheet1, and in my workbook i already create 3 sheets named (A, B, C).
I have no problem to copy group A,B,C data into their corresponding sheet, e.g. copy group A data into sheet A, however i find in some cases the selected cell at the beginning of each sheet is not in A1, e.g. the selected cell at the beginning maybe at somewhere other cells in excel (e.g. B10), this make the presentation looks messy, i want the all the data in each sheet start at A1. I know some of you may said using the code Range("a1").selected can manage this situation, however we need to use the "Do loop" to loop over each row in sheet1 to identify that row is belong to A,B or C, then we paste that row into the corresponding sheet. I found if i include the code Range("a1").selected, then each time the program will paste the row in Sheet1 into the cell A1 in sheet A,B and C, and at the end there will only one row appear in each sheets. What should i improve the program below so that each time the data in each group can be appeared at the beginning of cell A1 in their worksheet even sometimes the selected cell of each sheet is not in cell A1? Thanks.
Sub data_category()
Dim y As Integer
Dim x As String
Sheets("sheet1").Activate
Range("a3").Select
Do Until ActiveCell.Value = ""
y = ActiveCell.Offset(0, 3).Value
If y < 90 Then
x = "A"
ElseIf y < 120 Then
x = "B"
Else
x = "C"
End If
ActiveCell.Offset(0, 4).Value = x
Range(ActiveCell, ActiveCell.End(xlToRight)).Copy
Sheets(x).Activate
Range("a1").Select
ActiveCell.PasteSpecial
ActiveCell.Offset(1, 0).Select
Sheets("sheet1").Activate
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Rather than the Do-Loop approach, I would do this slightly different for a faster execution.
Logic
Find last row in Sheet1 of Col A
Insert formula =IF(D3<90,"A",IF(D3<120,"B","C")) in Col E starting at row 3
Next I will use autofilter to filter column E on A first and copy all data in one go to Sheet A. I will repeat the process for B and C
My Assumptions
Row 2 has headers. If not, tweak the code accordingly.
Code
I have commented the code so you will not have a problem understanding it, but if you do, then simply ask.
Option Explicit
Dim ws As Worksheet
Dim rng As Range
Sub Sample()
Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lRow As Long
With ws
'~~> Remove any filters
.AutoFilterMode = False
'~~> Find last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Insert formula in Col E
With .Range("E3:E" & lRow)
.Formula = "=IF(D3<90,""A"",IF(D3<120,""B"",""C""))"
.Value = .Value
End With
'~~> Identify the range to work with
Set rng = .Range("A2:E" & lRow)
'~~> Copy rows with relevant criteria
CopyData "A"
CopyData "B"
CopyData "C"
.AutoFilterMode = False
End With
End Sub
Private Sub CopyData(shName As String)
Dim rngToCopy As Range
'~~> Filter column E on the search string
With rng
.AutoFilter Field:=5, Criteria1:=shName
Set rngToCopy = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Copy all data in one go
If Not rngToCopy Is Nothing Then rngToCopy.Copy ThisWorkbook.Sheets(shName).Rows(1)
ws.AutoFilterMode = False
End Sub
In Action
Following from Sid's comment:
Sub data_category()
Dim y As Long
Dim x As String, c As Range, ws As Worksheet, wb As Workbook, cDest As Range
Set wb = ActiveWorkbook 'or ThisWorkbook: always good to be specific here
Set c = wb.Worksheets("sheet1").Range("a3") 'get a reference to the starting cell
Do Until Len(c.Value) = 0
y = c.Offset(0, 3).Value
Select Case y 'tidier then if...else if
Case Is < 90: x = "A"
Case Is < 120: x = "B"
Case Else: x = "C"
End Select
c.Offset(0, 4).Value = x
'direct copy to next empty row with no select/activate
Set cDest = wb.Worksheets(x).Cells(Rows.Count, 1).End(xlUp)
If Len(cDest).Value > 0 Then Set cDest = cDest.Offset(1, 0)
c.EntireRow.Copy cDest
Set c = c.Offset(1,0) '<<<<<<<<<<<<< edit - added
Loop
c.Parent.Activate
End Sub
Update Category Reports
Option Explicit
Sub UpdateCategoryReports()
Const sfRow As Long = 3 ' First Row (headers are in row 'sfRow - 1')
Const sfCol As Long = 1
Const dfRow As Long = 2 ' First Row (headers are in row 'dfRow - 1')
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
If slRow < sfRow Then Exit Sub ' no data (highly unlikely)
Dim slCol As Long
slCol = sws.Cells(sfRow - 1, sws.Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
Dim dws As Worksheet ' Destination Worksheet
Dim durg As Range ' Destination 'UsedRange'
Dim dcrg As Range ' Destination Clear Range
' Clear destination data.
For Each dws In wb.Worksheets(Array("A", "B", "C"))
Set durg = dws.UsedRange ' Destination Used Range
If durg.Rows.Count > 1 Then
' You don't want to clear the headers:
' e.g. if 'durg' is 'A1:J10' then 'dcrg' will be 'A2:J10'.
Set dcrg = durg.Resize(durg.Rows.Count - 1).Offset(1)
dcrg.Clear
End If
Next dws
Dim srrg As Range ' Source Row Range
Dim sRow As Long ' Source Row
Dim dfCell As Range ' Destination First Cell (Range)
Dim dRow As Long ' Destination (Available) Row
Dim sValue As Double ' Source Value
Dim dwsName As String ' Destination Worksheet Name
For sRow = sfRow To slRow
If IsNumeric(sws.Cells(sRow, "D").Value) Then
sValue = sws.Cells(sRow, "D").Value
If sValue < 90 Then
dwsName = "A"
ElseIf sValue < 120 Then
dwsName = "B"
Else
dwsName = "C"
End If
Set srrg = sws.Range(sws.Cells(sRow, "A"), sws.Cells(sRow, slCol))
sws.Cells(sRow, "E").Value = dwsName ' ?
Set dws = wb.Worksheets(dwsName)
dRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row + 1
Set dfCell = dws.Cells(dRow, "A")
' This will copy values, formats, and formulas. You may need another
' way. If there are formulas in source and you only need values,
' copying by assignment is the most efficient way. If you also need
' the formats you will have to use the least efficient PasteSpecial.
srrg.Copy Destination:=dfCell
'Else ' sValue is not numeric: do nothing
End If
Next sRow
'sws.Activate
'sws.Cells(1).Activate
Application.ScreenUpdating = True
MsgBox "Category reports updated.", vbInformation, "Category Reports"
End Sub
I'm trying to do a macro to produce a list based on a lookup list. For some reason the outer loop doesnt work, it only iterates once.
Sub Macro5()
Dim LookupRng As Range
Dim Store As String
Dim jrow As Integer
Dim irow As Integer
Dim i As Integer
Dim j As Integer
Set LookupRng = Sheet1.Range("B2") ' The Lookup range
jrow = Sheet2.Range("T" & Rows.Count).End(xlUp).Row ' last row of list of values to be searched
irow = Sheet1.Range("B" & Rows.Count).End(xlUp).Row ' last row of lookup range
Sheet3.Range("A2:A" & Rows.Count).Clear
For j = 2 To jrow
Store = Sheet2.Cells(j, 20).Value ' the value to be searched in the lookup range
For i = 1 To irow
If LookupRng.Value = Store Then
Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = LookupRng.Offset(0, -1).Value
End If
Set LookupRng = LookupRng.Offset(1, 0)
Next i
Next j
The i loop works, it searches all values that match "Store", but for some reason the j loop doesnt seem to be working, it doesnt jump to the next value of the "Store" list.
I'm new to this so would prefer a simple solution, but any help will be very appreciated
Loops with Offset
The issue was that you are not resetting the Lookup Range to the initial position after each inner loop finishes. So the following loops were trying to compare the values below the Lookup Range which were empty.
You should abandon the idea of 'offsetting' and use Cells or Range and increase the rows or define the range and use a For Each loop. But the best would be to use only one loop and use Application.Match to find a match.
A Quick Fix
Option Explicit
Sub lookupLoop()
Dim ilCell As Range ' Initial Lookup Cell Range
Dim lCell As Range ' Lookup Cell Range
Dim dCell As Range ' Destination Cell Range
Dim Store As Variant ' Current Value in Search Range
Dim iRow As Long ' Last Row of Lookup Range
Dim jRow As Long ' Last Row of Search Range
Dim i As Long ' Lookup Range Rows Counter
Dim j As Long ' Search Range Rows Counter
Set ilCell = Sheet1.Range("B2")
iRow = Sheet1.Range("B" & Sheet1.Rows.Count).End(xlUp).Row
jRow = Sheet2.Range("T" & Sheet2.Rows.Count).End(xlUp).Row
Sheet3.Range("A2:A" & Sheet3.Rows.Count).Clear
Set dCell = Sheet3.Range("A2")
For j = 2 To jRow
Store = Sheet2.Cells(j, "T").Value
Set lCell = ilCell '***
For i = 2 To iRow
If lCell.Value = Store Then
dCell.Value = lCell.Offset(0, -1).Value
Set dCell = dCell.Offset(1)
Exit For
End If
Set lCell = lCell.Offset(1)
Next i
Next j
End Sub
An Application.Match solution might look like this:
Sub lookupAM()
Dim lrg As Range ' Lookup Range (Read)
Dim vrg As Range ' Values Range (Write)
Dim srg As Range ' Search Range
Dim sCell As Range ' Current Cell in Search Range
Dim dCell As Range ' Current Cell in Destination Range
Dim cMatch As Variant ' Current Match
Dim lRow As Long ' Last Row of Lookup Range
Dim sRow As Long ' Last Row of Search Range
lRow = Sheet1.Range("B" & Sheet1.Rows.Count).End(xlUp).Row
Set lrg = Sheet1.Range("B2:B" & lRow)
Set vrg = lrg.Offset(, -1)
sRow = Sheet2.Range("T" & Sheet2.Rows.Count).End(xlUp).Row
Set srg = Sheet2.Range("T2:T" & sRow)
Sheet3.Range("A2:A" & Sheet3.Rows.Count).Clear
Set dCell = Sheet3.Range("A2")
For Each sCell In srg.Cells
cMatch = Application.Match(sCell.Value, lrg, 0)
If IsNumeric(cMatch) Then
dCell.Value = vrg.Cells(cMatch).Value
End If
Set dCell = dCell.Offset(1)
Next sCell
End Sub