I have formulas throughout a workbook that are returning an output if matched with X and "" if not. I am new to VBA and macro's and unsure of where to begin. But my goal is to have a macro that I could run that clears the formula if it is blank or "" across multiples sheets. I would note, I only want it to do this in certain columns of each sheet.
Example:
Sheet 1 has the formula in cells H10:K20, while Sheet 2 has the formula in AV8:AV400, etc. etc. The goal being to have it recognize "Sheet 1" is a range of H10:K20 where it would erase, Sheet 2 is AV8:AV400.
Any help would be greatly appreciated!
I had found another question that was kind of similar, but I could not figure out how to make it recognize different sheet names or specific ranges within my file. I have pasted the code I had found and tried to use below as well as the link here.
How to clear cell if formula returns blank value?
Sub ClearCell()
Dim Rng As Range
Set Rng = ActiveSheet.Range("A1")
Dim i As Long
For i = 1 To 10
If Rng.Cells(i,1) = "" Then
Rng.Cells(i,1).ClearContents
End If
Next i
End Sub
Maybe something very basic:
Sub ClearEmptyFormulas()
Dim ws As Worksheet
Dim rng As Range, cl As Range
For Each ws In ThisWorkbook.Sheets(Array("Sheet1", "Sheet2")) 'Extend the array or loop all worksheets
Select Case ws.Name
Case "Sheet1"
Set rng = ws.Range("H10:K20")
Case "Sheet2"
Set rng = ws.Range("AV8:AV400")
'Etc
End Select
For Each cl In rng
If cl.Value = "" Then
cl.ClearContents
End If
Next cl
Next ws
End Sub
Or even a bit simpler:
Sub ClearEmptyFormulas()
Dim rng As Range, cl As Range
Dim arr1 As Variant: arr1 = Array("Sheet1", "Sheet2")
Dim arr2 As Variant: arr2 = Array("H10:K20", "AV8:AV400")
For x = 0 To 1
Set rng = Sheets(arr1(x)).Range(arr2(x))
For Each cl In rng
If cl.Value = "" Then
cl.ClearContents
End If
Next cl
Next x
End Sub
Related
I am trying to write some VBA in excel that will clear all cells starting from the next empty cell in Column A (data starts from A2). For example, if A5 is blank then I want A5:P300 to all be cleared (as in all Formula and Data gone). And so on... so if A20 is blank then it deletes everything from A20:P300..
How would I go about writing this? I also need it to refer to the active workbook but a specific worksheet called ("Develop").
Thanks for any help provided.
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("R&DCosts(2)")
Set rng = x.Range("A2:A340").Cells(Rows.Count, 1).End(xlUp)
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
End Sub
Try this code, please:
Sub clearRange_Bis()
Dim sh As Worksheet, firstEmpt As Long
Set sh = ThisWorkbook.Worksheets("R&DCosts(2)")
firstEmpt = sh.Range("A1").End(xlDown).Row + 1
If firstEmpt > 1000000 Then
sh.Range("A2:P300").Clear
Else
sh.Range("A" & firstEmpt & ":P300").Clear
End If
End Sub
A more simple solution
Option Explicit
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("RDCosts(2)") ' you cannot use "&"
Set rng = x.Range("A2:A340", Cells(Rows.Count, 1).End(xlUp))
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
End Sub
I use VBA rarely and am always re-learning. This is my first posting.
I am using OCR to pull in tables from PDFs to individual worksheets (usually 100-200 tabs) and I have VBA programming ready to consolidate the data based on header values. But the headers are error prone and need to be reviewed first. I want to run a VBA macro that tests headers in row 1 against a set list and highlight those headers that exactly match.
I found a great start with Conditional formatting over huge range in excel, using VBA (Dictionary Approach) which tests lists, but I am struggling to convert the code to handle rows instead of columns. (Next I plan to have it run on every tab in the workbook, but am stuck at the testing stage).
Here is my current edit of the original code to pull from rows, but I get a subscript out of range on If dict2.Exists(vals(i)) Then
Option Explicit
Sub main3()
Dim mainRng As Range, list1Rng As Range
Dim mainDict As New Scripting.Dictionary, list1Dict As New
Scripting.Dictionary 'Main is Header and list1 is prescribed header list
Set mainRng = GetRange(Worksheets("Main"), "1") '<--| get "Main" sheet row "1" range from column A right to last non empty column
Set list1Rng = GetRange(Worksheets("list1"), "1") '<--| get "list1" sheet row "1" range from column A right to last non empty column
Set mainDict = GetDictionary(mainRng)
Set list1Dict = GetDictionary(list1Rng)
ColorMatchingRange2 list1Rng, list1Dict, mainDict
End Sub
Sub ColorMatchingRange2(rng1 As Range, dict1 As Scripting.Dictionary, dict2 As Scripting.Dictionary)
Dim unionRng As Range
Dim vals As Variant
Dim i As Long
vals = rng1.Value 'oringinal code transposed with = Application.Transpose(rng1.Value)
Set unionRng = rng1.Offset(rng1.Rows.Count).Resize(1, 1)
For i = LBound(vals) To UBound(vals)
If dict2.Exists(vals(i)) Then Set unionRng = Union(unionRng, rng1(1, i))
Next i
Set unionRng = Intersect(unionRng, rng1)
If Not unionRng Is Nothing Then
With unionRng.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
End If
End Sub
Function GetDictionary(rng As Range) As Scripting.Dictionary
Dim dict As New Scripting.Dictionary
Dim vals As Variant
Dim i As Long
vals = rng.Value 'oringinal code transposed with=Application.Transpose(rng.Value)
On Error Resume Next
For i = LBound(vals) To UBound(vals)
dict.Add vals(i), rng(1, i).Address
Next i
On Error GoTo 0
Set GetDictionary = dict
End Function
Function GetRangeRow(ws As Worksheet, rowIndex As String) As Range
With ws '<--| reference passed worksheet
Set GetRangeRow = .Range("A" & rowIndex, .Cells(1, .Columns.Count).End(xlToLeft)) '<--| set its row "rowIndex" range from row 1 right to last non empty column
End With
End Function
More background, the VBA will be in a Control Workbook with the set header list, and the code will run on the ActiveWorkbook which will be the data across many worksheets, but I believe I've got that figured out.
Simpler approach:
Sub HighlightMatchedHeaders()
Dim rngList As Range, c As Range, v
Dim sht As Worksheet, wb As Workbook
Set wb = ActiveWorkbook 'or whatever
'set the lookup list
With wb.Sheets("list")
Set rngList = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
For Each sht In wb.Worksheets
'ignore the "list" sheet
If sht.Name <> rngList.Worksheet.Name Then
'checking row 1
For Each c In Application.Intersect(sht.Rows(1), sht.UsedRange).Cells
v = Trim(c.Value)
If Len(v) > 0 Then
'has a header: check for match
If Not IsError(Application.Match(v, rngList, 0)) Then
c.Interior.Color = vbRed 'show match
End If
End If
Next c
End If
Next sht
End Sub
I'm using excel VBA and I'm trying to increment a Range selection in a loop.
Sub sorter()
Dim i As Integer
Dim copyLoc As String = "E1"
For i = 0 To 5
Range(copyLoc).Select '//what type is Range() supposed to take?
Selection.Copy
copyLoc = ActiveCell.Offset(0, 6) '//what type does ActiveCell.Offset return?
Next i
End Sub
I'm sure the problem is with the data type that ActiveCell.Offset is returning. Can anyone tell me what I should use instead? Thanks kindly!
Expanding on my comment above. "Range" is an object type. So you want to dim your variable as a "Range" not a string:
Sub sorter()
Dim i As Integer
Dim copyLoc As Range
Set copyloc = Range("E1")
For i = 0 To 5
'copy from copyloc and stick it in a cell offset 6 columns to the right
copyLoc.Copy Destination:=copyLoc.Offset(0,6)
'Increment to the next row?
Set copyLoc = copyLoc.Offset(1)
Next i
End Sub
I'm just guessing here at what you are trying to accomplish, but either way I think this will get you in the ballpark. If you are incrementing through 6 rows starting at E1 you could also use something like:
Sub sorter()
Dim rngRow as Range
Dim copyRange as Range
Set copyRange = Range("E1:E6")
'Loop through each row in the range's "Rows" collection
For each rngRow in copyRange.Rows
'Copy the value from the "E" column to the "K" column in this row
rngRow.Cells(1,11).value = rngRow.cells(1,5).value
Next rngRow
End Sub
Being able to loop/iterate through each item in a collection, and understanding that most objects in VBA are part of a collection is hugely powerful.
For instance, looping through all of the sheets in the ThisWorkbook.Worksheets collection:
Dim ws as worksheet
For each ws in ThisWorkbook.Sheets
'print the name of the worksheet to the "immediate" pane
debug.print ws.name
Next ws
Or looping through all cells in a range's "Cells" collection:
Dim rngCell as Range
For each rngCell in Range("A1:C50").cells
'do something to the cell
Next rngCell
Data is transferred from a web-form to Excel. Not every cell receives inputs. There are many cells, it is time consuming to scan each cell looking for text.
How do I get the text automatically copied from sheet1 to sheet2. But I don't want the cells displayed in the same layout as the original sheet. I would like them to be grouped together, eliminating all of the empty cells in between. I would also like to grab the title from the row that contains the text.
I found this macro:
Sub CopyC()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("C1:C10")
For Each cel In SrchRng
If cel.Value <> "" Then
cel.Offset(2, 1).Value = cel.Value
End If
Next cel
It grabs only cells that contain text, but it displays it in the exact same layout that it found it in. Any help would be appreciated and save me a lot of scan time in the future, thanks in advance :)
I guess this is what you are looking for:
Sub CopyNonBlankCells()
Dim cel As Range, myRange As Range, CopyRange As Range
Set myRange = Sheet1.Range("C1:C20") '---> give your range here
For Each cel In myRange
If Not IsEmpty(cel) Then
If CopyRange Is Nothing Then
Set CopyRange = cel
Else
Set CopyRange = Union(CopyRange, cel)
End If
End If
Next cel
CopyRange.Copy Sheet2.Range("C1") '---> enter desired range to paste copied range without blank cells
End Sub
Above code will copy range C1:C20 in Sheet1 to C1 in Sheet2
Got this from here.
EDIT: Following answer is based on your comment
________________________________________________________________________________
If you'll write something like below
Set myRange = Sheet1.Range("G:G")
Set myRange = Sheet2.Range("G:G")
myRange will be first set to Sheet1.Range("G:G") and then to Sheet2.Range("G:G") that means current range that myRange will have is Sheet2.Range("G:G").
If you want to use multiple ranges you can go for UNION function but there's a limitation that using UNION, you can combine different ranges but of only one sheet. And your requirement is to combine ranges from different sheets. To accomplish that I am adding a new worksheet and adding your G:G ranges from all the sheets to it. Then after using newly added sheet I am deleting it.
Following code will give you the desired output in the sheet named Result.
Sub CopyNonBlankCells()
Dim cel As Range, myRange As Range, CopyRange As Range
Dim wsCount As Integer, i As Integer
Dim lastRow As Long, lastRowTemp As Long
Dim tempSheet As Worksheet
wsCount = Worksheets.Count '--->wsCount will give the number of Sheets in your workbook
Set tempSheet = Worksheets.Add '--->new sheet added
tempSheet.Move After:=Worksheets(wsCount + 1)
For i = 1 To wsCount
If Sheets(i).Name <> "Result" Then '---> not considering sheet "Result" for taking data
lastRow = Sheets(i).Cells(Rows.Count, "G").End(xlUp).Row '--->will give last row in sheet
lastRowTemp = tempSheet.Cells(Rows.Count, "G").End(xlUp).Row '--->will give last row in newly added sheet
Sheets(i).Range("G1:G" & lastRow).Copy _
tempSheet.Range("G" & lastRowTemp + 1).End(xlUp)(2)
End If
Next i
lastRowTemp = tempSheet.Cells(Rows.Count, "G").End(xlUp).Row
Set myRange = tempSheet.Range("G1:G" & lastRowTemp) '--->setting range for removing blanks cells
For Each cel In myRange
If Not IsEmpty(cel) Then
If CopyRange Is Nothing Then
Set CopyRange = cel
Else
Set CopyRange = Union(CopyRange, cel)
End If
End If
Next cel
CopyRange.Copy Sheets("Result").Range("G1") '---> enter desired range to paste copied range without blank cells
Application.DisplayAlerts = False
tempSheet.Delete '--->deleting added sheet
Application.DisplayAlerts = True
End Sub
You can use arrays!
Instead of copying information from one cell to another, you can store all your information in an array first, then print the array on another sheet. You can tell the array to avoid empty cells. Typically, using arrays is the best way to store information. (Often the fastest way to work with info)
If you are only looking at one column, you could use a one-dimensional array. If you are looking at multiple columns, and want to print the information into the corresponding column (but different cells) in another page then you could a multi-dimensional array to store column number/anything else you wanted.
From your code, it could look like this:
Sub CopyC()
Dim SrchRng As Range, cel As Range
'Declare your 1-d array (I don't know what you are storing)
Dim myarray() as variant
Dim n as integer
Dim i as integer
Set SrchRng = Range("C1:C10")
'define the number of elements in the array - 1 for now, increase it as we go
n = 0
Redim myarray(0 to n)
For Each cel In SrchRng
If cel.Value <> "" Then
'redim preserve stores the previous values in the array as you redimension it
Redim Preserve myarray(0 to n)
myarray(n) = cel.Value
'increase n by 1 so next time the array will be 1 larger
n = n + 1
End If
Next cel
'information is now stored, print it out in a loop
'this will print it out in sheet 2 providing it is called "Sheet2"
For i = 0 to ubound(myarray)
Sheets("Sheet2").cells(i,1).value = myarray(i)
Next i
I need to copy data from one worksheet into another. However, I need a conditional copy operation that will skip rows based on criteria.
For example, if I start with...
Active Value
yes 1
no 2
no 3
yes 4
no 5
no 6
I only want to copy rows that are Active=yes, so I would end up with...
Value
1
4
Can someone show me how this is done with 1) a macro and 2) a formula?
Formula approach:
suppose your data are in sheet1, range A2:B7.
Then use this formula in sheet2 cell A2:
=IFERROR(INDEX(Sheet1!B:B,SMALL(IF(Sheet1!$A$2:$A$7="yes",ROW(Sheet1!$A$2:$A$7)),ROW()-ROW($A$2)+1)),"")
with array entry (CTRL+SHIFT+ENTER) and then drag it down.
VBA approach:
You can use AutoFilter:
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheet1 and Sheet2 to suit
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
With ws1
'assumung that your data stored in column A:B, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:B" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=1, Criteria1:="yes"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.Copy Destination:=ws2.Range("A1")
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
Note, if you want to copy only Value column, change
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
to
Set rngToCopy = .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible)
It's easy enough with a macro. Assuming you're copying from the first sheet to the second sheet, and that your sample above is in columns A and B, you could do the following:
Public Sub ConditionalCopy()
Dim copyRng As Range
Set copyRng = Worksheets(1).Range("B2:B7")
Dim pasteRng As Range
Set pasteRng = Worksheets(2).Range("A2")
Dim i As Long
i = 0
For Each cell in copyRng.Cells
If cell.Offset(0, -1).Value2 = "yes" Then
pasteRng.Offset(i,0).Value2 = cell.Value2
i = i + 1
End If
Next cell
End Sub
Doing it with a formula presents a challenge in terms of not leaving any blank rows on the second sheet. It would be pretty trivial to just use the following in the second sheet:
=If(A2 = "yes",b2,"")
And copy that down, but you're going to end up with blank rows that you'll have to go back and delete yourself. If you have the ability to use the macro, it's straightforward enough that I would go that route rather than sinking too much effort into devising a formula. The more I think about it, the more I feel like it has to be a programmatic solution to avoid double references.
If you use seperate counters for the source and destination rows, and use cell references rather than ranges the following routine should do the trick
Public Sub copyactivevalue()
Dim i As Integer
Dim j As Integer
Dim acts As Excel.Worksheet
Dim news As Excel.Worksheet
Set acts = Excel.Worksheets("sheet1")
Set news = Excel.Worksheets("sheet2")
With acts
j = 2
For i = 2 To 7
If acts.Cells(i, 1).Value = "yes" Then
news.Cells(j, 1) = acts.Cells(i, 2).Value
j = j + 1
End If
Next
End With
Set acts = Nothing
Set news = Nothing
End Sub
Hope this helps