Anybody knows here how to look for a value that is greater than 1 in a column?
Set fileSheet = wb.ActiveSheet
fileSheet.Name = "Test"
Set rng = fileSheet.Range("D:D")
Set rngFound = rng.Find(">1")
If rngFound Is Nothing Then
MsgBox "No value"
End If
I'm trying to do it that way, but I know that if you put a double qoute, it will be treated as a String, so is there any way I can look for a greater than 1 value before filtering it? Please note that I will be working with a column that has thousands of data.
This should speed things up, assuming the cells contain numbers rather than formulas. An array would be much quicker, but depends what exactly you are trying to achieve.
Sub x()
Dim r As Range, filesheet As Worksheet, Rng As Range
Set filesheet = wb.ActiveSheet
filesheet.Name = "Test"
Set Rng = filesheet.Range("D1", filesheet.Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)
For Each r In Rng
If r.Value > 1 Then
'do whatever
End If
Next r
End Sub
Use two for cycles for the index of last column and row like this.
Or, use the active sheet's range's foreach cycle.
More info:
How to iterate through all the cells in Excel VBA or VSTO 2005
displays cells that are > 1 for the range D1 to D100
Dim i As Integer
With ThisWorkbook.Sheets(1)
For i = 1 To 100
If .Cells(i,4).Value > 1 Then
MsgBox "Value Found! Cell D " & i
End If
Next i
End With
Related
I'm trying to fill blank cells in a certain region with 0. The reagion should be defined in the current workbook but in sheet2 (not the current sheet). Also the place where it is supposed to fill is between columns
BU:CQ in the current region (not all 100 000 000 lines). Just the number of lines that define the table between columns BU and CQ. I know the problem lies in defining the region... See the code below.
What is missing?
Sub FillEmptyBlankCellWithValue()
Dim cell As Range
Dim InputValue As String
On Error Resume Next
InputValue = "0"
For Each cell In ThisWorkbook.Sheets("Sheet2").Range(BU).CurrentRegion
'.Cells(Rows.Count, 2).End(xlUp).Row
If IsEmpty(cell) Then
cell.Value = InputValue
End If
Next
End Sub
I've this code that i'm positive that works! But i don't wnat selection! I want somthing that specifies the sheet and a fixed range.
Now my idea is to replace "selection" with the desired range. - In this case in particular the range should be 1 - between BU:CQ; 2 - starting at row 2; 3 - working the way down until last row (not empty = end of the table that goes from column A to DE)
Sub FillEmptyBlankCellWithValue()
Dim cell As Range
Dim InputValue As String
On Error Resume Next
For Each cell In Selection
If IsEmpty(cell) Then
cell.Value = "0"
End If
Next
End Sub'
PS: And I also need to specify the sheet, since the button that will execute the code will be in the same workbook but not in the same sheet.
Use SpecialsCells:
On Error Resume Next 'for the case the range would be all filled
With ws
Intersect(.UsedRange, .Range("BU:CQ")).SpecialCells(xlCellTypeBlanks).Value = 0
End With
On Error GoTo 0
MUCH faster than looping !
Try using cells() references, such as:
For i = cells(1,"BU").Column to cells(1,"CQ").Column
cells(1,i).value = "Moo"
Next i
In your current code you list Range(BU) which is not appropriate syntax. Note that Range() can be used for named ranges, e.g., Range("TheseCells"), but the actual cell references are written as Range("A1"), etc. For Cell(), you would use Cells(row,col).
Edit1
With if statement, with second loop:
Dim i as long, j as long, lr as long
lr = cells(rows.count,1).end(xlup).row
For i = 2 to lr 'assumes headers in row 1
For j = cells(1,"BU").Column to cells(1,"CQ").Column
If cells(i,j).value = "" then cells(i,j).value = "Moo"
Next j
Next i
First off, you should reference the worksheet you're working with using:
Set ws = Excel.Application.ThisWorkbook.Worksheets(MyWorksheetName)
Otherwise VBA is going to choose the worksheet for you, and it may or may not be the worksheet you want to work with.
And then use it to specify ranges on specific worksheets such as ws.Range or ws.Cells. This is a much better method for specifying which worksheet you're working on.
Now for your question:
I would reference the range using the following syntax:
Dim MyRange As Range
Set MyRange = ws.Range("BU:CQ")
I would iterate through the range like so:
Edit: I tested this and it works. Obviously you will want to change the range and worksheet reference; I assume you're competent enough to do this yourself. I didn't make a variable for my worksheet because another way to reference a worksheet is to use the worksheet's (Name) property in the property window, which you can set to whatever you want; this is a free, global variable.
Where I defined testWS in the properties window:
Public Sub test()
Dim MyRange As Range
Dim tblHeight As Long
Dim tblLength As Long
Dim offsetLen As Long
Dim i As Long
Dim j As Long
With testWS
'set this this to your "BU:CQ" range
Set MyRange = .Range("P:W")
'set this to "A:BU" to get the offset from A to BU
offsetLen = .Range("A:P").Columns.Count - 1
'set this to your "A" range
tblHeight = .Range("P" & .Rows.Count).End(xlUp).Row
tblLength = MyRange.Columns.Count
End With
'iterate through the number of rows
For i = 1 To tblHeight
'iterate through the number of columns
For j = 1 To tblLength
If IsEmpty(testWS.Cells(i, offsetLen + j).Value) Then
testWS.Cells(i, offsetLen + j).Value = 0
End If
Next
Next
End Sub
Before:
After (I stopped it early, so it didn't go through all the rows in the file):
If there's a better way to do this, then let me know.
so recently I have been looking into using defined ranges to copy data instead of selecting, copying and pasting cells. This way I hope to optimise the performance and the runtime of my code.
Unfortunately I have come to face a problem I wasn't able to solve on my own.
When defining a range I want to rearrange the columns in a different order.
For example:
Set my_range = Sheets("Sheet1").Range("A2:E2,G2:H2,J2:K2,M2")
Works well, as the columns I fill into the range are behind each other in the sheet. But now I have this:
Set yo_range = Sheets("Sheet2").Range("D2,AV2,L2,H2,Q2,AE2,AG2")
If I fill these ranges into a new sheet the yo_range will fill the columns I put into it but not in the order I written down. It will put it down in the order according to the original one. In this example yo_range would put the data in this order into the new sheet:
D2 | H2 | L2 | Q2 | AE2 | AG2 | AV2
How can I fix this? I want the order to be another one than the original one.
Also - as you can see my_range has more columns than yo_range. How can I let yo_range be filled into the new sheet but at certain points leave columns out? For example:
my_range(A2:E2) goes into A2:E2 in the new sheet
yo_range(D2,AV2) goes into A:B in the new sheet, then leave C out and then paste yo_range(L2,H2) into D:E in the new sheet
I hope that I was able to explain my problem well and that there is somebody able and willing to help me. Any help is appreciated.
Edit:
Here's the code that puts the values from the ranges into the new sheet
Do
If Application.WorksheetFunction.CountA(my_range) > 0 Then
my_range.Copy ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0)
Set my_range = my_range.Offset(1, 0)
Else
Exit Do
End If
Loop
Do
If Application.WorksheetFunction.CountA(yo_range) > 0 Then
yo_range.Copy ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0)
Set yo_range = yo_range.Offset(1, 0)
Else
Exit Do
End If
Loop
We can see that the Copy method will re-arrange the data left-to-right. Try this:
Option Explicit
Public Sub CheckClipboard()
Dim ws As Worksheet
Dim rngToCopy As Range
Dim objData As Object
Dim varContents As Variant
' test data b,c,d,e,f,g in Sheet1!B1:G1
Set ws = ThisWorkbook.Worksheets("Sheet1")
ws.Range("B1:G1").Value = Array("b", "c", "d", "e", "f", "g")
Set rngToCopy = ws.Range("E1:F1,G1,B1:C1") '<-- note not left-to-right order
rngToCopy.Copy '<-- copy
' this is a late bound MSForms.DataObject
Set objData = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
' copy current cell formula to clipboard
objData.GetFromClipboard
varContents = objData.GetText
Debug.Print varContents '<-- re-arranged left-to-right
' cancel copy
Application.CutCopyMode = False
End Sub
I get this in the immediate window:
b c d e f g
So, using Copy is not going to work for what you want to do.
In order to 'paste' the data in the order that you set it in the Range, you need to iterate each Area of the Range and then each cell (i.e. Range) in each Area. See the test code below which replicates your issue and presents a solution:
Option Explicit
Sub MixColumns()
Dim ws As Worksheet
Dim rngIn As Range
Dim rngOut As Range
Dim lng As Long
Dim rngArea As Range
Dim rngCell As Range
Set ws = ThisWorkbook.Worksheets("Sheet1")
' example 1
Set rngIn = ws.Range("B1:C1,E1:F1,G1") '<-- 5 cells, non-contiguous, forward order
Set rngOut = ws.Range("B2:F2") '<-- 5 contiguous cells
rngIn.Copy rngOut '<-- works
' example 2 - OP problem
Set rngIn = ws.Range("E1:F1,G1,B1:C1") '<-- 5 cells, non-contiguous, odd order
Set rngOut = ws.Range("B3:F3") '<-- 5 contiguous cells
rngIn.Copy rngOut '<-- should be e,f,g,b,c but gets b,c,e,f,g
' example 3 - solution for OP problem
Set rngIn = ws.Range("E1:F1,G1,B1:C1") '<-- 5 cells, non-contiguous, odd order
Set rngOut = ws.Range("B4:F4") '<-- 5 contiguous cells
lng = 1 '<-- rngOut cell counter
' iterate areas
For Each rngArea In rngIn.Areas
' iterate cells in area
For Each rngCell In rngArea.Cells
rngOut.Cells(1, lng).Value = rngCell.Value '<-- copy single value
lng = lng + 1 '<-- increment rngOut counter
Next rngCell
Next rngArea '<-- results in e,f,g,b,c
End Sub
Give this output:
I am New to Excel VBA and next to write code to Find and replace the whole string when a partial match is achieved multiple sheets.
Find must be used as I am searching in cells with a formula but want to change the value displayed.
The items I would like to search for and replace are all in a column on another sheet. I have provided pictures to better explain.
I believe it should look something like
'Replace the whole string when a partial match is achieved
'find -findobj = sheet.find
'if find finds - does findobj have data
'replace in findobj
'Replace the whole string when a partial match is achieved
Being new its been hard for me to come up with something so any suggestions or help would be great.
This answer will use the cells in the first sheet and check them against the cells in the second and third sheets (just change For x = 2 To 3 to whatever to change what sheets it targets).
Sub PartialReplace()
Dim wsO As Worksheet, wsX As Worksheet
Dim x As Long
Dim cell1 As Range, cell2 As Range
Dim rng1 As Range, rng2 As Range
'set original worksheet as first sheet
Set wsO = ActiveWorkbook.Sheets("Sheet1")
'set range to find values from
Set rng1 = NonBlankCells(wsO)
'loop through all cells to find values from
For Each cell1 In rng1
'loop through 2nd and 3rd sheets
For x = 2 To 3
Set wsX = ActiveWorkbook.Sheets(x)
'find all cells to check on sheet being checked
Set rng2 = NonBlankCells(wsX)
'loop through all cells on sheet being checked
If Not rng2 Is Nothing Then
For Each cell2 In rng2
'if partial match, replace cell value
If cell2.Text Like "*" & cell1.Text & "*" Then
cell2.Value = cell1.Value
End If
Next cell2
End If
Set rng2 = Nothing
Next x
Next cell1
Set rng1 = Nothing
End Sub
Function NonBlankCells(ws As Worksheet) As Range
Dim ct1 As Long, ct2 As Long
On Error Resume Next
ct1 = ws.Cells.SpecialCells(xlCellTypeConstants).Count
ct2 = ws.Cells.SpecialCells(xlCellTypeFormulas).Count
On Error GoTo 0
If ct1 > 0 And ct2 = 0 Then
Set NonBlankCells = ws.Cells.SpecialCells(xlCellTypeConstants)
ElseIf ct1 = 0 And ct2 > 0 Then
Set NonBlankCells = ws.Cells.SpecialCells(xlCellTypeFormulas)
ElseIf ct1 > 0 And ct2 > 0 Then
Set NonBlankCells = Union( _
ws.Cells.SpecialCells(xlCellTypeFormulas), _
ws.Cells.SpecialCells(xlCellTypeConstants))
End If
End Function
For future reference, remember that posting a question without showing anything you've tried will typically result in the question being closed: see https://stackoverflow.com/help/mcve.
I am trying to piece together code to make my macro work correctly. This approach has served me well in the past but I cannot seem to adapt any code correctly.
I found the following
Sub way()
Dim Cell As Range
For Each Cell In Range("A1").CurrentRegion
If Len(Cell) < 2 Then Cell.EntireRow.Delete
Next Cell
End Sub
I can adapt the If Len(Cell) criteria to my liking. For example = 10
I do not know how to adapt the code to make it search through all cells in column A and delete the appropriate rows. The code above only does it for A1.
Ideally I would like to delete all rows with cells in column A that have a length of 10 characters. Or alternatively, with a completely different set of code, delete all other rows that do not contain cells in column A that have a length of 10 characters.
When deleting rows it is best to loop backwards:
Sub way()
Dim ws As Worksheet
Dim i As Long
Dim lastrow As Long
Set ws = ActiveSheet
lastrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For i = lastrow To 1 Step -1
If Len(ws.Cells(i, 1)) < 2 Then ws.Rows(i).Delete
Next i
End Sub
Essentially, your loop is going through every cell in the Range.CurrentRegion property radiating out from A1. Your narrative expresses that you only want to examine column A but delete the Range.EntireRow property.
The For .. Next loop stepping backwards proposed by Scott Craner is likely your best bet but if you are more comfortable with a For ... Each In loop then yours can be adjusted.
Sub way()
Dim cl As Range, dels As Range
With Worksheets("Sheet1")
For Each cl In .Range("A1").CurrentRegion.Columns(1).Cells
If Len(cl.Value2) = 10 Then
If Not dels Is Nothing Then
Set dels = Union(dels, cl)
Else
Set dels = cl
End If
End If
Next cl
End With
If Not dels Is Nothing Then _
dels.EntireRow.Delete
End Sub
The logic to delete rows that did not have a value in column A that was 10 characters, symbols or digits long would be If Len(cl.Value2) <> 10 Then.
I haven't checked for syntax, but something like this should work:
dim idx as integer
idx = 1
while Range("A" + cstr(idx)).value <> ""
'insert your delete logic here...
idx = idx + 1
wend
I have been struggling with coming up with a solution to deleting all cells that are unique across my excel sheet.
I have an excel sheet that look something like this:
cat dog shrimp donkey
dog human wale
wale bear
dog donkey shrimp human wale
and I would like to now remove all values that are unique amongst all cells (so here that would be removing cat and bear) while keeping all the order of all the rows etc. intact.
I also have a few rows that are completely empty (but that I can't delete).
I have tried the following macro, but it's my first vba macro (and I know it is stupidly inefficient :) ) For some reason it doesn't delete anything whereas I can't see the logic error.
Code:
Sub doit()
Dim rng As Range
Dim rngtoCheck As Range
Dim cell As Range
Dim isCellUnique As Boolean
Dim cellToCheck As Range
Set rng = Range("A1:Z20")
Set rngtoCheck = Range("A1:Z20")
For Each cell In rng
isCellUnique = True
For Each cellToCheck In rngtoCheck
If cell.Value = cellToCheck.Value AND cell.row <> cellToCheck.row Then
isCellUnique = False
End If
Next cellToCheck
If isCellUnique = True Then
cell.ClearContents
End If
Next cell
End Sub
The idea is that I loop through the entire range and for each cell I check if any other cell in the range has the same value, but is not on the same row. If both check out I keep the value, otherwise I clear the cell.
What am I doing wrong?
You can use Application.WorksheetFunction.CountIf to check if the cell is repeated more than once?
Is this what you are trying?
Tried And Tested
Sub doit()
Dim rng As Range, aCell As Range
'~~> Change this to the relevant sheet
Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:Z20")
For Each aCell In rng
If Not Len(Trim(aCell.Value)) = 0 Then
'~~> Check if word occurs just once
If Application.WorksheetFunction.CountIf(rng, aCell.Value) = 1 Then
MsgBox aCell.Value & " is unique"
'
'~~> Do what you want here
'
End If
End If
Next aCell
End Sub