I have two columns. The first column contains the code and the second column contains the null values (0).
Is there a way that I can delete these 2 columns, if the second column value is equal to zero?
I tried using this, but it only deletes the zero values in the second column.
Sub ClearZero()
For Each cell In Range("C6:D4005")
If cell.Value = "0" Then cell.Clear
Next
End Sub
you can do it in this way:
Sub ClearZero()
For Each cell In Range("D6:D4005")
If cell.Value = "0" Then
cell.Clear
cell.offset(0, -1).Clear
End If
Next
End Sub
Another way to achieve what you want without looping.
LOGIC:
Identify the worksheet you are going to work with.
Remove any autofilter.
Check if the column D has 0 anywhere.
Find last row in column D. Better than hardcoding D4005
Construct your range.
Filter column D based on 0.
Identify the filtered range.
Clear the cells in 2 columns without looping.
CODE:
Is this what you are trying? I have commented the code so you should not have a problem understanding it but if you do them simply ask :)
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim FilteredRange As Range
'~~> Set this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Remove any filters
.AutoFilterMode = False
'~~> Find last row
lRow = .Range("D" & .Rows.Count).End(xlUp).Row
'~~> Check if the column D has 0 anywhere
If Application.WorksheetFunction.CountIf(.Range("D1:D" & lRow), 0) Then
'~~> Filter column D on 0
.Range("D1:D" & lRow).AutoFilter Field:=1, Criteria1:=0
'~~> Identify your range
Set FilteredRange = .AutoFilter.Range
'~~> Clear the range in 1 go!
FilteredRange.Offset(1, 0).Resize(FilteredRange.Rows.Count - 1).Clear
FilteredRange.Offset(1, -1).Resize(FilteredRange.Rows.Count - 1).Clear
End If
'~~> Remove any filters
.AutoFilterMode = False
End With
End Sub
BEFORE:
AFTER:
Related
I'm working on VBA Excel, and,
I Need to filter table, then make a loop in filtered values.
But i tryed:
With Sheets("plan8")
.Activate
totalAdhoc = .Range("A2", .Range("A2").End(xlDown)).Count
With .Range("A2:S" & totalAdhoc + 1)
.CurrentRegion.Select
.AutoFilter Field:=1, Criteria1:=batch, Operator:=xlFilterValues
For Each selectedV In Selection
r = selectedV
Next
End With
End With
In this way, my loop pass over each cell, in rows and columns.
If i use Range, it pass over hidden cells, then filter isn't efective.
A
B
C
D
xx
a
1
x
xx
s
2
x
xx
f
3
x
I Filtered this table for Column "A", then i need compare my variable to column "B", then change value of Column "D".
The For in entire table is very slow.
Without trying to figure out exactly what you're doing, here is an example of using a loop through a range and checking if row is hidden/filtered or not:
Sub loopSomeRows()
Dim aCell As Range, LoopRange As Range, ws As Worksheet
Set ws = ActiveSheet 'or whatever
Set LoopRange = ws.Range("B:B") ' sample
For Each aCell In Intersect(LoopRange, ws.UsedRange).Cells
If aCell.EntireRow.Hidden Then
'this row is hidden so it would be ignored.
Else
'this row is visible, so write code for what you want to happen
Debug.Print "Visible " & aCell.Value
End If
Next aCell
End Sub
The task at hand is to search in column A to see what values I have (they are in form of letters) and paste for each unique entry, its value once in another column.
Here is a visual explanation:
What I came up with was to create a For loop that iritiates through column A and created a conditional that if it found a certain value then it would insert the value in the range. Here is the code:
For i = 1 to 26
if cells(i,26).value= "A" Then
Range ("C1")= "A"
Elseif cells(i,26).value = "B" then
Range ("C2").value = "B"
ElseIf (i,26).value = "C" then
Range ("C3").value = "C"
EndIf
Next i
end sub
I want to cut this process short as my data set is really big with lots of company names. Any recommendations? I believe there has to be a way of knowing the values without having to look at all the values yourself.
If the goal is to just get a unique list of values found in Column A output to Column C you can use the below macro. This is really just recreating the steps of one method you would manually take to find unique values. Not the most sophisticated solution, but it works
Create a copy of your column with company names (using last available column in sheet)
De-dup the helper column
Copy the de-duped column to destination
Delete the helper column
Assumes the last column on worksheet is not used
Sub Unique()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, lc As Long
'Determine Range Size
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
lc = ws.Cells(1, ws.Columns.Count).Column
'Copy Company Names To Helper Column/Remove Duplicates
ws.Range("A2:A" & lr).Copy ws.Cells(1, lc)
ws.Columns(lc).RemoveDuplicates Columns:=1, Header:=xlNo
lr = ws.Cells(ws.Rows.Count, lc).End(xlUp).Row
'Output Unique Values From Helper Column
ws.Range(ws.Cells(1, lc), ws.Cells(lr, lc)).Copy
ws.Range("C2").PasteSpecial xlPasteValues
'Delete Helper Column
ws.Columns(lc).Delete
End Sub
Note my comment on post. VBA may not be needed here at all
Here's a slightly different version of using .RemoveDuplicates which also removes blank cells.
You can also do this without VBA. Just copy the desired column to another and use Remove Duplicates under Data tab.
Sub Unique_Values()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
'Getting all the values in column A (except header)
'Copying them into cell C2 and below
ws.Range("A2", Range("A1048576").End(xlUp)).Copy Range("C2")
'setting the header for the column C
ws.Range("C1").Value = "What companies are in Column A?"
'Removing duplicates and blanks from column C
With ws.Range("$C$2", Range("C1048576").End(xlUp))
.Value = .Value
.RemoveDuplicates Columns:=1, Header:=xlNo
On Error Resume Next
.SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
On Error GoTo 0
End With
End Sub
Although I agree with the coding convention used in the other answer, I think it is over-complicating the problem a little bit that would cause confusion for beginners.
I think both answers so far will give you exactly what you want, and perhaps could be simplified even further?
Sub GetUniqueQuick()
Dim LastRow As Long
Application.ScreenUpdating = False
LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Sheet1").Range("A2:A" & LastRow).Copy Sheets("Sheet1").Range("C2")
Sheets("Sheet1").Range("C1:C" & LastRow).RemoveDuplicates Columns:=1, Header:=xlYes
End Sub
Using the dynamic features of MS 365 you can simply apply the worksheet function UNIQUE() over a given range, e.g.
= UNIQUE(A2:A100)
or integrate it in a user defined function
Function GetCompanies(rng As Range)
If rng.Columns.Count > 1 Then Exit Function ' allow only one column
GetCompanies = Application.Unique(rng) ' return function result as 2-dim array
End Function
As empty cells result in pseudo-uniques with a 0 output, you could call them in formula with an added cosmetical blank string :
=GetCompanies(A2:A100)&""
I have a sheet where the cells in Column A auto-populate based on user input. Row 1 is the Headers. Row 2 is fully setup from B:JG with formulas as an example. I would like to have a button that runs a script to check Column A of each row, starting with 3, to see if its empty. If Column A is not empty, it should copy the FORMULAS from B2:JG2 and paste them into Columns B:JG on each row. If Column A is empty, I want it to leave the other columns blank.
I'm just diving into VBA, so any help with a script to accomplish is appreciated.
Example: Rows 3-110 have data in Column A, so B2:JG2 FORMULAS get copied into their B:JG columns. All rows after 110 get nothing because Column A is empty.
The button is on a sheet called "HexBox" and the sheet I need to update is "HexClean".
The user enters some info on the "HexBox" sheet and A:A is auto-populated based on their answers. So there could be 10 or 1000 rows in A:A with values and the rest up to 5000 will be "" if not applicable.
This approach simply
Copies the formulas from 2nd row down to the last used row as determined by Column A (one operation). Note that this step is indifferent of blanks in your column. That is handled in the following 2 steps
Loops through Column A and gather up instances of blank rows by adding them to a Union (collection of cells) (0 operations)
Clears the contents of the Union that is built in step 2 (one operation)
This is a more effecient way to go. Copying & pasting the formulas inside your loop one row at a time will lead to a lot of spread sheet operations. This method has a max of 2 operations
Sub HexSub()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("HexClean")
Dim LR As Long, i As Long, ClearMe As Range
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("B2:JG2").Copy
ws.Range(ws.Cells(3, "B"), ws.Cells(LR, "JG")).PasteSpecial xlPasteFormulas
For i = 3 To LR
If ws.Range("A" & i) = "" Then
If Not ClearMe Is Nothing Then
Set ClearMe = Union(ClearMe, ws.Range("A" & i))
Else
Set ClearMe = ws.Range("A" & i)
End If
End If
Next i
If Not ClearMe Is Nothing Then ClearMe.EntireRow.ClearContents
End Sub
If your range will never have blanks followed by more values, then you can just get rid of the loop and everything below it
If the non-blank cells in column A are typed values then SpecialCells should be able to find them quickly.
Sub populateBelow()
Dim frng As Range
With Worksheets("sheet3")
Set frng = .Range(.Cells(2, "B"), .Cells(2, "JG"))
With .Range(.Cells(3, "A"), .Cells(.Rows.Count, "A").End(xlUp))
With .SpecialCells(xlCellTypeConstants, xlTextValues + xlNumbers)
frng.Copy Destination:=.Offset(0, 1)
End With
End With
End With
End Sub
Sub CopyToMany()
Dim xRow As Range, aCel As Range
For Each xRow In ActiveSheet.UsedRange.Rows
If xRow.Row > 2 Then
Set aCel = xRow.Cells(1, 1)
If aCel.Value <> "" Then
ActiveSheet.Range("B2:JG2").Copy Destination:=ActiveSheet.Range("B" & xRow.Row & ":JG" & xRow.Row)
End If
End If
Next xRow
End Sub
Please see below code I have found on the internet, which is currently working to a certain degree for me.
Could someone possibly commentate on what each line of this code means so I can understand what its doing?
Im trying to understand it with little programming knowledge and add additional code to look for additional values to paste into additional sheets.
I'm also trying to work out how to make them paste to certain rows one after the other and not maintain the row they were originally in on sheet 1.
Code:
Sub Test()
Dim rw As Long, Cell As Range
For Each Cell In Sheets(1).Range("H:H")
rw = Cell.Row
If Cell.Value = "Dept 1" Then
Cell.EntireRow.Copy
Sheets("Sheet2").Range("A" & rw).PasteSpecial xlPasteValues
End If
Next
End Sub
--
Many thanks
I've added comments as requested. To paste them onto the same row, look at removing the rw variable and replacing it with something that increments by one each time
Sub Test()
'declare variables
Dim rw As Long, Cell As Range
'loop through each cell the whole of column H in the first worksheet in the active workbook
For Each Cell In Sheets(1).Range("H:H")
'set rw variable equal to the row number of the Cell variable, which changes with each iteration of the For loop above
rw = Cell.Row
'check if the value of Cell variable equals Dept 1
If Cell.Value = "Dept 1" Then
'copy the entire row if above is true
Cell.EntireRow.Copy
'paste to the same row of Sheet 2
Sheets("Sheet2").Range("A" & rw).PasteSpecial xlPasteValues
End If
Next
End Sub
Here is your Code Commented hope you understand:
Sub Test()
' Variables Defined as follows:
Dim rw As Long, Cell As Range
' Loop Searching each Cell of (Range H1 to end of last H on sheet1
For Each Cell In Sheets(1).Range("H:H")
' now determine current row number:
rw = Cell.Row
' Test cell value if it contain >> Dept 1 as value:
If Cell.Value = "Dept 1" Then
' Select that row and copy it:
Cell.EntireRow.Copy
' now paste the values of that row into A column and rw row on sheet2:
Sheets("Sheet2").Range("A" & rw).PasteSpecial xlPasteValues
' You should add following to:
' Disable marching ants around copied range:
Application.CutCopyMode = False
End If
Next
End Sub
I have two columns, Column (A) and Column (B) in a spreadsheet.
Column (A) contains names extracted from a query (ex. Brian, Bob, Bill, etc...) and column (B) contains one of three statuses (Assigned, In Progress, or Pending).
However, this query sometimes pulls up some line items showing "Assigned" for the status with no name, therefore corresponding cell representing the name in Column (A) is blank. So I manually fill in those empty cells with "Unknown".
What I want to do is to create a macro that finds the every empty cell in column (A) and fill in the word "Unknown" if the cell to its right contains the word "Assinged".
So the conditions are:
Blank cell in column (A)
Correspoding cell to its right (column B) contains the word "assinged"
This is my Code:
Private Sub CommandButton2_Click()
For Each cell In Columns("A")
If ActiveCell.Value = Empty And ActiveCell.Offset(0, 1).Value = "Assigned" Then ActiveCell.Value = "Unknown"
Next cell
End Sub
There is no need to loop here, take advantage of excels built in methods which will execute faster.
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
With ActiveSheet.UsedRange
.AutoFilter Field:=1, Criteria1:=""
.AutoFilter Field:=2, Criteria1:="Assigned"
If WorksheetFunction.CountBlank(.Columns(1)) > 0 Then
If .Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
.Columns(1).SpecialCells(xlCellTypeBlanks).Value = "Unknown"
End If
End If
.AutoFilter
End With
Application.ScreenUpdating = True
End Sub
Welcome to SO.
Try this code. It will work a bit faster and should get you what you want.
Update: Made the code more bullet proof!
Private Sub CommandButton2_Click()
Dim cel As Range, rngFind As Range, rngFilter As Range
Dim wks As Worksheet
Set wks = Sheets("sheet1")
With wks
'-> Error check to make sure "blanks" exist
Set rngFind = .Range("A1:A" & .Range("B" & Rows.Count).End(xlUp).Row).Find("", lookat:=xlWhole)
If Not rngFind Is Nothing Then
Set rngFilter = .Range("A1:B" & .Range("B" & Rows.Count).End(xlUp).Row)
rngFilter.AutoFilter 1, "="
'-> Error check to make sure "assigned" exists for blank cells
Set rngFind = .Columns("B:B").SpecialCells(xlCellTypeVisible).Find("Assigned", lookat:=xlWhole)
If Not rngFind Is Nothing Then
'-> okay, it exists. filter and loop through cells
rngFilter.AutoFilter 2, "Assigned"
Set rngFind = Intersect(.UsedRange, .UsedRange.Offset(1), .Columns(1)).SpecialCells(xlCellTypeVisible)
For Each cel In rngFind
If cel.Offset(0, 1).Value = "Assigned" Then cel.Value = "Unknown"
Next cel
End If
End If
End With
End Sub
If you only need to do this a few times you could
format your used range as a table
on column A filter to only show "(Blanks)"
on column B filter to only show "assinged"
select all the resulting cells in column B
press alt + : to select only the visible cells
press F2
type "unknown"
press ctrl + enter
Your bad data should be good now!
Obviously this is a non-vba based solution but if you can avoid coding it's probably for the best.