I am trying to write a Macro in Excel VBA whereas any row under C2 gets hidden if the cell text contains "hide". I want the entire column to be evaluated no matter how many cells are filled (hence why LastRow is goes until the end). Don't know why this isn't working - it tells me I have a type mismatch. Can someone help pls
Sub Hide()
Worksheets("Sheet1").Activate
StartRow = Range("C2")
LastRow = Range("C2", Range("C2").End(xlDown))
For i = StartRow To LastRow
If Cells(i, iCol).Value <> "hide" Then
Cells(i, iCol).EntireRow.Hidden = False
Else
Cells(i, iCol).EntireRow.Hidden = True
End If
Next i
End Sub
you have some issues in your code:
StartRow and LastRow are not relates to Integer or Long, you implicitly defined them as Range because row property for the Range("C2") and Range("C2", Range("C2").End(xlDown)) not specified;
Range("C2", Range("C2").End(xlDown)) will return correct range only in case when range will not contains empty cells, otherwise it will return range from C2 to last not empty cell in column C;
iCol not defined in your code, so it need to be changed to something like iCol = Range("C2").Column;
your updated code below:
Sub Hide()
Dim StartRow As Long, LastRow As Long, iCol As Long, cl As Range
Set cl = Range("C2") 'start range
iCol = cl.Column
StartRow = cl.Row
LastRow = Cells(Rows.Count, iCol).End(xlUp).Row
For i = StartRow To LastRow
If Cells(i, iCol).Value <> "hide" Then
Cells(i, iCol).EntireRow.Hidden = False
Else
Cells(i, iCol).EntireRow.Hidden = True
End If
Next i
End Sub
additional variant how you can achieve desired result:
Sub Hide2()
Dim checkRng As Range, cl As Range
Set checkRng = Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row)
For Each cl In checkRng
If cl.Value <> "hide" Then
cl.EntireRow.Hidden = False
Else
cl.EntireRow.Hidden = True
End If
Next cl
End Sub
Related
I am trying to write a macro that will look in column A on sheet1 and see if it is missing any values from column A on sheet2 or column A on sheet3. If it is missing have the value added to the bottom of the column A on sheet1. The same value may exist on sheet2 and sheet3 but it only needs to be represented once on sheet1.
I'm working with the code below.
Sub newRow()
Dim rngSh1 As Range, rngSh2 As Range, rngSh3 As Range, mySelSh2 As Range, mySelSh3 As Range
Dim lastRowSh1 As Long, lastRowSh2 As Long, lastRowSh3 As Long
Dim wb As Worksheet
Dim cell As Range
Set wb = ThisWorkbook
With wb
lastRowSh1 = Worksheets("Sheet1").Range("A" & .Rows.Count).End(xlUp).Row
lastRowSh2 = Worksheets("Sheet2").Range("A" & .Rows.Count).End(xlUp).Row
lastRowSh3 = Worksheets("Sheet3").Range("A" & .Rows.Count).End(xlUp).Row
Set rngSh1 = Worksheets("Sheet1").Range("A1:A" & lastRowSh1)
Set rngSh2 = Worksheets("Sheet2").Range("A1:A" & lastRowSh2)
Set rngSh3 = Worksheets("Sheet3").Range("A1:A" & lastRowSh3)
End With
For Each cell In rngSh2.Cells
If IsError(Application.Match(cell.Value, rngSh1, 0)) Then
If mySelSh2 Is Nothing Then
Set mySelSh2 = cell
Else
Set mySelSh2 = Union(mySelSh2, cell)
End If
End If
Next cell
If Not mySelSh2 Is Nothing Then mySelSh2.Copy Destination:=Worksheets("Sheet1").Range("A" & lastRowSh1 + 1)
For Each cell In rngSh3.Cells
If IsError(Application.Match(cell.Value, rngSh1, 0)) Then
If mySelSh3 Is Nothing Then
Set mySelSh3 = cell
Else
Set mySelSh3 = Union(mySelSh3, cell)
End If
End If
Next cell
If Not mySelSh3 Is Nothing Then mySelSh3.Copy Destination:=Worksheets("Sheet1").Range("A" & lastRowSh1 + 1)
End Sub
I've made every adjustment I can think of but with every change I make I get a different error.
Any help would be greatly appreciated. Thanks!
Save yourself a little bit of time using a Scripting.Dictionary:
Option Explicit
Sub test()
Dim dict As New Scripting.dictionary, sheetNum As Long
For sheetNum = 2 To Sheets.Count
With Sheets(sheetNum)
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim rowNum As Long
For rowNum = 1 To lastRow
Dim dictVal As Long: dictVal = .Cells(rowNum, 1).Value
If Not dict.Exists(dictVal) Then dict.Add dictVal, 0
Next rowNum
End With
Next sheetNum
With Sheets(1)
Dim checkableRangeLastRow As Long: checkableRangeLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim checkableRange As Range: Set checkableRange = .Range(.Cells(1, 1), .Cells(checkableRangeLastRow, 1))
Dim dictKey As Variant
For Each dictKey In dict.Keys
If IsError(Application.Match(dictKey, checkableRange, 0)) = True Then
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(lastRow + 1, 1).Value = dictKey
End If
Next dictKey
End With
End Sub
You add all values in your not-master-sheet into dict then loop through that list; if it's not found in your master-sheet, then you add then to the end of the list.
A significant note is that the Type of value used as the dictVal may cause the IsError() statement to always be True if it is not the same Type as the data being assessed in the checkableRange.
I have created below code which works like IF Col"B" any cell <> "" And Col"L" any cell = "Leop" then add row below to the active cell.
I mean I'm trying to achieve is to insert single row after certain row which contain in column B any value, and if column L in same row contains value = "Leop". Then add the row after that certain row.
But an error is appear. Compile Error: Invalid use of property on xlDown
Your help will be appreciated to fix it.
From this:
to this:
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long
Dim rng As Range
Dim rng2 As Range
Dim i As Long
Dim p As Long
Dim dat As Variant
Dim datt As Variant
Dim IRow As Long
Set ws = Thisworkbooks.Sheets("Sheet2")
With ws
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B2:B" & LRow)
Set rng2 = .Range("L2:L" & LRow)
dat = rng
datt = rng2
IRow = Selection.Row
For i = LBound(dat, 1) To UBound(dat, 1)
For p = LBound(datt, 1) To UBound(datt, 1)
If dat(i, 1) <> "" And datt(p, 1) = "Leop" Then
Rows(IRow + 1).Select
Selection.Insert Shift: xlDown
End If
End Sub
It will be like in formula:
IF(AND(B2<>"",L2="Leop"),"InsertRowBelow to Row 2 If condition is met","")
and will drag it down to the lastRow.
Thisworkbooks.Sheets("Sheet2") should be Thisworkbook.Sheets("Sheet2") and missing = in Selection.Insert Shift:= xlDown
Inserting or deleting rows will change the last row number so start at the bottom and work upwards.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet, LRow As Long, r As Long
Dim n As Long
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
LRow = .Range("B" & .Rows.Count).End(xlUp).Row
For r = LRow To 2 Step -1
If .Cells(r, "B") <> "" And .Cells(r, "L") = "Leop" Then
.Rows(r + 1).Insert shift:=xlDown
n = n + 1
End If
Next
End With
MsgBox n & " rows inserted", vbInformation
End Sub
Try this with autofilter, you dont have to loop through each row. So it will work faster for larger data.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long, cl As Range
Set ws = ThisWorkbook.Sheets("Sheet2")
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("L1:L" & LRow).AutoFilter 1, "Leop"
For Each cl In ws.Range("_FilterDatabase").SpecialCells(12).Cells
If ws.Range("B" & cl.Row) <> "" Then
cl.Offset(1).EntireRow.Insert Shift:=xlDown
End If
Next
ws.AutoFilterMode = False
End Sub
Detailed Problem
I'm attempting to write a VBA code that would loop through Column D,
if it finds Cells(i,"D") = "Good" then the code would search the entire column D for that value in cells (i,"D") and change all it's value to "Good"
Here is an Image on before the code.
Here is an Image after the code.
My Attempt:
Dim i As Integer
For i = 1 To Rows.Count
If Cells(i, "m") = "Good" Then
x = Cells(i, "m")
Next i
I think you would have to store the value ( ID Number ) and then search for it which I assigned "X". Once "X" is found change the status to "Good"
Use an AutoFilter
Option Explicit
Sub makeGood()
Dim i As Long, tmp As Variant
Dim dict As Object, k As Variant
'late bind a dictionary
Set dict = CreateObject("scripting.dictionary")
dict.CompareMode = vbTextCompare
With Worksheets("sheet11")
'remove any existing autofilters
If .AutoFilterMode Then .AutoFilterMode = False
'collect values from column D
tmp = .Range(.Cells(2, "D"), .Cells(.Rows.Count, "D").End(xlUp)).Value
'build dictionary of unique ID NUMs
For i = LBound(tmp, 1) To UBound(tmp, 1)
dict.Item(tmp(i, 1)) = vbNullString
Next i
'work with D:G range
With .Range(.Cells(1, "D"), .Cells(.Rows.Count, "G").End(xlUp))
'loop through unique ID NUMs
For Each k In dict.Keys
'autofilter on key
.AutoFilter field:=1, Criteria1:=k, visibledropdown:=False
'autofilter on Good
.AutoFilter field:=4, Criteria1:="good", visibledropdown:=False
'check for visible cells
If Application.Subtotal(103, .Offset(1, 0).Cells) > 0 Then
'remove the Good autofilter
.AutoFilter field:=4
'step down off the header and put Good in the filtered cells
With .Resize(.Rows.Count - 1, 1).Offset(1, 3)
.SpecialCells(xlCellTypeVisible) = "Good"
End With
End If
'clear autofilter
.AutoFilter field:=1
.AutoFilter field:=4
Next k
End With
End With
End Sub
May be a bit convoluted, but here is an idea.
Sub f(strSearchFor as string)
Dim r As Excel.Range
Dim d As New Scripting.Dictionary
Set r = Range("a1:b10")
For Each c In r.Columns(2).Cells
If StrComp(c.Value, strSearchFor, vbTextCompare) = 0 Then
If Not d.Exists(c.Value) Then
d.Add c.Offset(0, -1).Value, c.Value
End If
End If
Next c
For Each c In r.Columns(1).Cells
If d.Exists(c.Value) Then
c.Offset(0, 1).Value = d(c.Value)
End If
Next c
Set r = Nothing
Set d = Nothing
End Sub
You can add a helper column and do it with a formula only:
Add the following formula eg. in H2 (of your example) and pull it down:
=IF(COUNTIFS(D:D,D2,G:G,"Good")>0,"Good",G2)
You could try:
Option Explicit
Sub trst()
Dim i As Long, y As Long, LastRow As Long
Dim ID As String, Status As String
With ThisWorkbook.Worksheets("Sheet1") '<- Change Workbook / Sheet names
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
ID = .Range("D" & i).Value
Status = .Range("G" & i).Value
For y = 2 To LastRow
If ID = .Range("D" & y).Value Then
.Range("G" & y).Value = Status
End If
Next y
Next i
End With
End Sub
Test with arrais. With arrais it is much faster
Option Explicit
Sub Subst()
With ThisWorkbook.Sheets("Sheet1")
Dim ArrayColumnD As Variant
ArrayColumnD = .Range("D1:D" & .Cells(.Rows.Count, 4).End(xlUp).Row)
Dim ArrayColumnG As Variant
ArrayColumnG = .Range("G1:G" & .Cells(.Rows.Count, 7).End(xlUp).Row)
Dim ID As String
Dim RowActual As Long
Dim RowTest As Long
For RowActual = 2 To UBound(ArrayColumnD)
If ArrayColumnG(RowActual, 1) = "Good" Then
ID = ArrayColumnD(RowActual, 1)
For RowTest = 2 To UBound(ArrayColumnD)
If ArrayColumnD(RowTest, 1) = ID Then
ArrayColumnG(RowTest, 1) = "Good"
End If
Next RowTest
End If
Next RowActual
.Range("G1:G" & .Cells(.Rows.Count, 7).End(xlUp).Row) = ArrayColumnG
End With
End Sub
I'm trying to copy all rows from between two cell values and paste the values in a new column in a new worksheet. Let's say my data is structured in one excel column as such:
x
1
2
3
y
x
4
5
6
y
So I want to copy the 123 and the 456, paste them in a new worksheet in columns A and B respectively, like so:
A B
1 1 4
2 2 5
3 3 6
The code that I have working copies the data just fine, but it only pastes them below each other. Is there any way to amend the following code to paste the copied data in a new column every time the loop runs through?
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
rownum = 1
colnum = 1
lastrow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
Do
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
rownum = rownum + 1
If (rownum > lastrow) Then Exit For
Loop Until .Cells(rownum, 1).Value = "y"
endrow = rownum - 1
rownum = rownum + 2
Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy
Sheets("Sheet2").Select
ActiveSheet.Range("A1").Select
ActiveSheet.Paste
Next rownum
End With
End Sub
There's a lot going on in that code that doesn't need to. Have a look at the below and see if you can follow what's happening:
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
colnum = 1 'start outputting to this column
Dim rangetocopy As Range
With Worksheets("Sheet1")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
If .Cells(rownum, 1).Value = "y" Or rownum = lastrow Then
endrow = rownum
Set rangetocopy = Worksheets("Sheet1").Range("A" & startrow & ":A" & endrow)
rangetocopy.Copy Sheets("Sheet2").Cells(1, colnum)
colnum = colnum + 1 ' set next output column
End If
Next rownum
End With
End Sub
you could use:
SpecialCells() method of Range object to catch "numeric" values range
Areas property of Range object to loop through each set of "numeric" range
as follows:
Sub CommandButton1_Click()
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)
Dim area As Range
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
to manage data of any format (not only "numeric") between "x"s or "x"s and "y"s, then use
AutoFilter() method of Range object to filter data between "x"s or "x"s and "ys" "
SpecialCells() method of Range object to catch not empty values range
Areas property of Range object to loop through each set of "selected" range
as follows:
Sub CommandButton1_Click()
Dim area As Range
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>x", Operator:=xlAnd, Criteria2:="<>y"
With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants) '.Offset(-1)
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
.AutoFilterMode = False
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
This type was already mentioned, but since I wrote it, I'll share it as well, using range areas.
This is also assuming layout is actual in the original question and that you are trying to extract a group of numbers.
Sub Button1_Click()
Dim sh As Worksheet, ws As Worksheet
Dim RangeArea As Range
Set sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
For Each RangeArea In sh.Columns("A").SpecialCells(xlCellTypeConstants, 1).Areas
RangeArea.Copy ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1)
Next RangeArea
End Sub
I an trying towrite a simple VBA code where some cell values are combined.
Problem with code bellow is that Cell Object in the loop keeps selecting whole row, not just one cell in Row Collection
Dim Cell As Range
Dim Row As Range
Set Row = Rows(ActiveCell.Row)
Set Cell = ActiveCell
For Each Cell In Row
With Cell
If IsNumeric(InStr(1, Right(.Value, 1), "/")) Then
.Value = .Value & .Offset(0, 1).Value
.Offset(0, 1).Delete (xlShiftToLeft)
End If
End With
Next Cell
Try this. For this example, assumptions made about data being on Sheet1 and the start row (stRow) and start col (testCol) of the data. Amend these to suit your conditions.
Option Explicit
Sub combine()
Dim ws As Worksheet
Dim stRow As Long, endRow As Long, testCol As Long, endCol As Long
Dim rnum As Long, cnum As Long
Dim cl As Range
Set ws = Sheets("Sheet1")
stRow = 1
testCol = 1
With ws
endRow = .Cells(Rows.Count, testCol).End(xlUp).Row
For rnum = stRow To endRow
endCol = .Cells(rnum, Columns.Count).End(xlToLeft).Column
For cnum = testCol To endCol - 1
Set cl = .Cells(rnum, cnum)
If Right(cl, 1) = "/" And Right(cl.Offset(0, 1), 1) <> "/" Then
If IsNumeric(Left(cl.Value, Len(cl.Value) - 1)) Then
cl.Value = cl.Value & cl.Offset(0, 1).Value
cl.Offset(0, 1).Delete (xlShiftToLeft)
End If
End If
Next cnum
Next rnum
End With
End Sub
Although not specified by you, this code does not combine an adjacent cell which also has a trailing "/". This on the basis that we shouldn't 'remove' a 'test' value. If this condition not required it is easily changed.