I'm trying to highlight the entire row grey if the value in column A begins with "ABC" as well as delete everything right of that cell. Any ideas on how to do this?
Dim DataRange As Range
Set DataRange = Range("A1:U" & LastRow)
Set MyRange = Range("A2:A" & LastRow)
For Each Cell In MyRange
If UCase(Left(Cell.Value, 3)) = "ABC" Then
Cell.EntireRow.Interior.ColorIndex = 15
Else
End If
Next
Here is pretty straightforward approach:
Dim lastRow As Long
Dim row As Long
Dim temp As String
' insert your sheet name here
With ThisWorkbook.Worksheets("your sheet name")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' you can change the starting row, right now its 1
For row = 1 To lastRow
' store whats in col A in a temporary variable
temp = Trim(CStr(.Range("A" & row).Value))
' if col A isn't 'ABC' clear & grey entire row
If UCase(Left(.Range("A" & row).Value), 3) <> "ABC" Then
.Rows(row).ClearContents
.Rows(row).Interior.ColorIndex = 15
' place temp variable value back in col A and make interior No Fill
.Range("A" & row).Value = temp
.Range("A" & row).Interior.ColorIndex = 0
End If
Next
End With
Here is another example; you stated "clear everything to the right" so I added offset to clear the contents of the cells not in column A.
Dim x As Long
For x = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If UCase(Left(Cells(x, 1).Value, 3)) = "ABC" Then
Range(Cells(x, 1), Cells(x, Columns.Count).End(xlToLeft)).Interior.ColorIndex = 15
Range(Cells(x, 1).Offset(, 1), Cells(x, Columns.Count).End(xlToLeft)).ClearContents
End If
Next x
Related
[Copy A2 to E2 till the end of row of the table and check if the cell is within the same month](https://i.stack.imgur.com/Q7YAx.png)
Hi,
I would like to loop through rows from a sheet table from column A2 to E2 to A3 to E3... till the end of the table Ai to Ei by defining a variable and counting the last row of the table.
As the second step, I would like to copy the cells into another sheet and fill it the corresponding months.
[Desired Output--> it will copy the data and return to another sheet in the corresponding month] (https://i.stack.imgur.com/zhgYh.png)
Instead, I've changed the data type into a number format and have set up two condition to loop through.
eg. 1/1/2017 change to 42736
28/2/2017 change to 42794
Sub Mike_Copy_cell()
Dim i As Long 'for looping inside each cell
Dim myvalue As Variant
Dim Lastrow As Long
Const StartRow As Byte = 2
Dim LastMonth As Long
("Mike Filter").Select
Lastrow = Range("A" & StartRow).End(xlDown).Row
For i = StartRow To Lastrow
myvalue = Range("H" & i).Value
If myvalue \< Sheets("Automate Report").Range("A" & i).Value \_
'First data Feb Data 42794 \< Jan Category 42736
Then Sheets("Automate Report").Range("B" & i).Value = ""
'leave the cells in blanks and loop through next cell
If myvalue > Sheets("Automate Report").Range("A" & i).Value _
'First data Feb Data 42794 > Jan Category 42736
Then Range("A" & i, "E" & i).Copy Sheets("Automate Report").Range("B" & i, "F" & i)
'Copy the cells into corresponding category
Next i
End sub()
In my output, it is able to loop through and copy all the cells. However, I am wondering the reason why VBA output is not able leave any blank cells when the first condition is met ?
**I am expecting some blanks in the table if it is not data is not within the same month or in my case is less than criteria I have set. **
The output of my code
If myvalue < Sheets("Automate Report").Range("A" & i).Value _
Then Sheets("Automate Report").Range("B" & i).Value = ""
Greatly appreciate if you can advise the flaws in my code. Massive Thanks.
Best regards,
Kenneth
I'll try to help. But before, may I give you two suggestions that might help you?
First, for me the best way to find the last row is, instead of using xldown from the first row, using xlup from the very last row of excel. This way, if there is a blank in any middle row, the code still gives you the last row with value.
Second, I found that referring to any cells with the "range" method may limit you sometimes when using variables in this reference. I think using the "cells(row, column)" method is more useful.
Why not trying this?
Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Sorry for the suggestions, It's just that I wish someone had taught them to me sooner.
Back to the topic, I think the problem is how you structure the "if" statement. Allow me to change it a bit:
Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = StartRow To Lastrow
myvalue = cells(i, 8).Value
'if myvalue date is equal or previous to the one found in Ai...
If myvalue <= Sheets("Automate Report").cells(i, 1).Value then
Sheets("Automate Report").cells(i, 2).Value = ""
'but if myvalue is later than Ai...
else
sheets("Automate Report").select
range(cells(i, 1), cells(i, 5).select
selection.copy
cells(i, 2).select
activesheet.paste
end if
Next i
Hope this helps. Best regards,
Mike
I'm not sure what your code is doing but consider using an array(12) of row numbers, one for each month. Copy lines into corresponding month and increment the row number for that month. For example ;
Option Explicit
Sub Mike_Copy_cell()
Const LINES_MTH = 5 ' lines per month
Dim wb As Workbook
Dim wsIn As Worksheet, wsOut As Worksheet
Dim lastrow As Long, rIn As Long, rOut(12) As Long
Dim uid As String, prevuid As String
Dim dAVD As Date, m As Long, n As Long
Set wb = ThisWorkbook
Set wsIn = wb.Sheets("Mike Filter")
Set wsOut = wb.Sheets("Automate Report")
' space out months
For n = 0 To 11
rOut(n + 1) = 2 + n * LINES_MTH
wsOut.Cells(rOut(n + 1), "A").Value2 = MonthName(n + 1)
Next
n = 0
With wsIn
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For rIn = 2 To lastrow
dAVD = .Cells(rIn, "D")
' create a unique ID to skip duplicates
uid = .Cells(rIn, "A") & Format(.Cells(rIn, "D"), "YYYY-MM-DD")
If uid <> prevuid Then
m = Month(dAVD)
.Cells(rIn, "A").Resize(, 5).Copy wsOut.Cells(rOut(m), "B")
rOut(m) = rOut(m) + 1
n = n + 1
End If
prevuid = uid
Next
End With
MsgBox n & " lines copied to " & wsOut.Name, vbInformation
End Sub
I'm trying to create a Display/Dashboard that lists cars sold within a month broken down by salesman.
I have an input sheet, where the cars are entered weekly.
I'm looking for a way to search the lists of cars sold each week and return the values under the corresponding salesman.
I used IF AND functions however don't believe these are suitable for what I am trying to achieve.
Monthly Display
[Weekly Input]
If I understand you correctly, and if you don't mind to change your "header" in sheet Display ... then first you need to copy your original workbook and test the following sub on the copied workbook.
First, make the header for sheet Display like this :
Each name is separated by one column. So Mark H will be in column L, and so on.
Step run the sub, please don't hit "play" to run the sub - because the sub is not complete in the select case ---> It only define the oFill for DB and PR.
I don't write a complete sub, but I hope this sample sub may help you to get started.
Sub test()
Dim sh1 As Worksheet: Dim sh2 As Worksheet
Dim arr1: Dim arr2: Dim arr3
Dim rg As Range: Dim cell As Range: Dim oFill As Range
Dim x As String: Dim y As String
Dim j As Long: Dim i As Long
'set the worksheet as sh1 and sh2 variable, and set the range of sh1 column A as rg variable
Set sh1 = Sheets("Weekly Input")
Set sh2 = Sheets("Display")
Set rg = sh1.Range("A2", sh1.Range("A" & Rows.Count).End(xlUp))
'this is the loop for 4 week in sheet Weekly Input
'where rg at the first iteration is column A
'2nd iteration is column L, and so on
For j = 1 To 4
'this is the loop to each row of data value in rg (the N/U column)
For Each cell In rg
'join the name, model, reg and date with comma separated into variable x
x = cell.Offset(0, 2).Value & "," & cell.Offset(0, 3).Value & "," & _
cell.Offset(0, 1).Value & "," & cell.Offset(0, 9).Value
'make x value into into array as arr1 variable
arr1 = Split(x, ",")
'join the prds, fin, px and discount with comma separated into variable y
y = cell.Offset(0, 5).Value & "," & cell.Offset(0, 6).Value & "," & _
cell.Offset(0, 7).Value & "," & cell.Offset(0, 8).Value
'make y value into array as arr2 variable
arr2 = Split(y, ",")
'create arr3 variable by joining arr1 and arr2
ReDim arr3(0 To 1, 0 To UBound(arr1))
For i = 0 To UBound(arr3, 2)
arr3(0, i) = arr1(i)
arr3(1, i) = arr2(i)
Next
'check what is the value of the looped row,column S/C
Select Case UCase(cell.Offset(0, 4).Value)
'if the value is DB
Case "DB"
'check, if the looped cell value is u, set the range in sh2 to a blank cell of column B as oFill variable
'other then "u" (meaning "n"), set the range in sh2 to a blank cell of column D as oFill variable
If cell.Value = "u" Then Set oFill = sh2.Range("B" & Rows.Count).End(xlUp).Offset(1, 0) _
Else Set oFill = sh2.Range("D" & Rows.Count).End(xlUp).Offset(1, 0)
'same thing with PR
'add a similar code for MH and MD pointing to the needed range
Case "PR"
If cell.Value = "u" Then Set oFill = sh2.Range("G" & Rows.Count).End(xlUp).Offset(1, 0) _
Else Set oFill = sh2.Range("i" & Rows.Count).End(xlUp).Offset(1, 0)
End Select
'put the arr3 value into oFill
oFill.Resize(4, 2).Value = Application.Transpose(arr3)
'looped to the next row of column N/U in sh2
Next cell
'set the rg for the next iteration of the week
Set rg = rg.Offset(0, 11)
Next j
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.
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
I pasted the entire macro below but this is the important part.
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
It works as is except it is creating unnecessary data because I don't know how to use variable names in a range object. My ranges are currently hard coded such as ("A1:A1000"), when I would like it to be something like ("A1:A & LastRow).
Also I have to explicitly call out column names to copy because the range won't accept a variable name like ("currentColumn & 1:currentColumn & LastRow).
Is there a way to use a varible name as part of a range object so we can use them in loops?
Sub prepareWorkbook()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Dim wks As Worksheet
Set wks = wbk.ActiveSheet
Dim colx As Long
Dim ColumnCount As Long
Dim MySheetName As String
MySheetName = "Import"
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
'identify the Id column and move it to 1st column
Dim answer As Variant
Dim IdColumn As Range
answer = Application.InputBox("Enter Letter of Id column")
If Columns(answer).Column = 1 Then
Else
'cut Id column from current location and insert it at column index 1
Columns(answer).Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
End If
'trim the PartNumber column of any trailing spaces
Dim c As Range
For Each c In Range("A1:A10000")
c.Value = Application.Trim(Replace(c.Value, Chr(160), Chr(32)))
Next
' insert column every other column
' Loop through number of columns.
ColumnCount = Application.WorksheetFunction.CountA(Rows(1)) * 2
'step 2 means skip every other
For colx = 2 To ColumnCount Step 2
Columns(colx).Insert Shift:=xlToRight
Next
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
wks.Cells.EntireColumn.AutoFit
MsgBox ("Done")
End Sub
Assuming the you are running code in the Worksheet added here:
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
Also not sure what is the purpose of this code, nevertheless using it for the sample
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Try this:
Dim lLastRow As Long
lLastRow = wbk.Worksheets(MySheetName).UsedRange.SpecialCells(xlLastCell).Row
Rem This updates only columns B, D, F & H - adjust as needed
For colx = 2 To 8 Step 2
With wbk.Worksheets(MySheetName)
Rem Creates Range as Range(Cells(rIni,cIini), Cells(rEnd,cEnd))
rem Corresponding code for "Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value" (see comment above)
Range(.Cells(2, colx), .Cells(lLastRow, colx)) = .Cells(2, colx).Offset(-1, 1).Value
End With: Next
Something like:
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("B2:B" & LastRow).Value = Range("B2").Offset(-1, 1).Value
Range("D2:D" & LastRow).Value = Range("D2").Offset(-1, 1).Value
Range("F2:F" & LastRow).Value = Range("F2").Offset(-1, 1).Value
Range("H2:H" & LastRow).Value = Range("H2").Offset(-1, 1).Value
Although this answer won't be applied to your situation, I feel like this could help answer some questions you have in there.
When specifying a range, you can separate the column (letter) and row (number) and use your own variables.
In a for loop, this could look like
for i = 1 to 100
Range("A" & i).Value = Range("A"&i).Offset(, 1).Value
next
You can also determine the number of the row of the selected cell using:
dim RowNb as long
RowNb = (ActiveCell.Row)
This also applies to columns, and can be used in a loop like I mentionned at the start.
The one thing that was conspicuous by its absence in your description was any mention of the nature of the data in the worksheet. You mentioned A1 briefly but your range value assignments started at row 2 so it may be inferred that row 1 contains column header labels.
Sub prepareWorkbook()
Dim wbk As Workbook, wks As Worksheet
Dim colx As Long
Dim lc As Long, lr As Long
Dim MySheetName As String
Set wbk = ThisWorkbook 'no idea what this does
Set wks = wbk.ActiveSheet 'no idea what this does
MySheetName = "Import"
'no idea what this does or what sht is
'LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
With Sheets(2)
.Name = MySheetName
If CBool(Application.CountIf(.Rows(1), "PartNumber")) Then
colx = Application.Match("PartNumber", .Rows(1), 0)
Else
colx = .Range(Application.InputBox("Enter Letter of Id column") & 1).Column
End If
If .Columns(colx).Column > 1 Then
'cut Id column from current location and insert it at column index 1
.Columns(colx).Cut
.Columns(1).Insert Shift:=xlToRight
End If
'quickest way to trim trailing spaces is with Text-to-Columns, Fixed Width
With .Columns(1)
.TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, FieldInfo:=Array(0, 1)
End With
' insert column every other column (working backwards toward A1)
For lc = .Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
.Columns(lc).Insert Shift:=xlToRight
Next lc
For lc = (.Cells(1, Columns.Count).End(xlToLeft).Column - 1) To 2 Step -2
'let's put the row-by-row value in instead of a single value into all cells
lr = .Cells(Rows.Count, lc + 1).End(xlUp).Row
With .Cells(2, lc).Resize(lr - 1, 1)
.Cells = .Offset(-1, 1).Value
.EntireColumn.AutoFit
End With
Next lc
End With
Set wbk = Nothing
Set wks = Nothing
End Sub
Explanations as comments in code.