I'm a beginner. Just learning by Googleing, but cannot find a solution for this. Please help.
I want to run the below macro.
I have multiple cells named "CV_=CVCAL" in the same column.
What I want is for the macro to find the first cell with the value "CV_=CVCAL" and offset to the adjacent cell. If the adjacent cell has a particular value, if the value is below lets say "1.5" i want to fill it will a cell style 'bad'.
I want the macro to go through all the cells that have the name CV_=CVCAL and do the same thing until there is no more cells named CV_=CVCAL.
Sub If_CV()
Range("A1").Select
Set FoundItem = Range("C1:C1000").Find("CV_=CVCAL")
FoundItem.Offset(columnOffset:=1).Select
If ActiveCell.Value >= 1.5 Then
ActiveCell.Style = "Bad"
End If
End Sub
Sounds like you want to loop through your values.
Determine the end of your range
Loop through your range and check your criteria
Sub If_CV()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, i As Long
lr = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
For i = 2 To lr
If ws.Range("C" & i) = "CV_=CVCAL" Then
If ws.Range("D" & i) >= 1.5 Then
ws.Range("D" & i) = "Bad"
End If
End If
Next i
End Sub
A basic loop would be simpler:
Sub If_CV()
Dim c As Range, ws As Worksheet
For Each ws in ActiveWorkbook.Worksheets
For Each c in ws.Range("C1:C1000").Cells
If c.Value = "CV_=CVCAL" Then
With c.offset(0, 1)
If .Value >= 1.5 Then .Style = "Bad"
End With
End If
Next ws
Next c
End Sub
Related
I've already used Set to create ranges with names in the format rng1a. I then use a loop to go through i (integer) values, and want to set the final range to use to be the one that has the name in the form 'rng' & i & "a"
My initial thought was something along the lines of Range("rng" & i & "a"), however this results in an error.
Set rng1a = Range("B2", Range("B2").End(xlDown))
Set rng2a = Range("D2", Range("E2").End(xlDown))
i = 1
Do
("rng" & i & "a").Copy 'this is the problem
Range("A2").End(xlDown).Offset(1,0).PasteSpecial xlPasteValues
i = i + 1
Loop Until i = 3
I keep getting an error message with
run-time error '1004':
Method 'Range' of object '_Global' failed
My thought is that I need to format the name of the range as a string so that it can be recognised as the name of a range. Is there a way to do this?
I haven't tested either of these, but I think they should work.
Be wary of using End(xldown) as if you don't have anything underneath the first cell you will go straight to the very last cell. Better to work up from the bottom (see Damian's answer).
Sub x1()
'Array
Dim rng(1 To 2) As Range, i As Long
Set rng(1) = Range("B2", Range("B2").End(xlDown))
Set rng(2) = Range("D2", Range("E2").End(xlDown))
For i = 1 To 2
rng(i).Copy
Range("A2").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Next i
End Sub
Sub x2()
'Named ranges
Dim i As Long
Range("B2", Range("B2").End(xlDown)).Name = "rng1a"
Range("D2", Range("E2").End(xlDown)).Name = "rng2a"
For i = 1 To 2
Range("rng" & i & "a").Copy
Range("A2").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
Next i
End Sub
This should do it:
Option Explicit
Sub Test()
Dim i As Long, LastRow As Long
Dim arrRanges(1 To 2) As Range
With ThisWorkbook.Sheets("NameYourSheet") 'change the sheet name
Set arrRanges(1) = .Range("B2", .Range("B2").End(xlDown))
Set arrRanges(2) = .Range("D2", .Range("E2").End(xlDown))
For i = LBound(arrRanges) To UBound(arrRanges)
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
arrRanges(i).Copy .Range("A" & LastRow)
Next i
End With
End Sub
Remember to always declare all your variables, and reference to workbooks and worksheets.
What you actually want to do (I think) is copy the contents of the columns B,C D etc, into Column A underneath each other.
Sub CopyStuff
Dim i as integer
dim r as range
for i = 1 to 6
set r = range(cells(1,i),cells(1,i).end(xldown))
r.copy
range("a1").end(xldown).offset(1,0).pastespecial xlpastevalues
next i
End sub
You can have array of ranges :
Set rng1a = Range("B2", Range("B2").End(xlDown))
Set rng2a = Range("D2", Range("E2").End(xlDown))
For Each rng in Array(rng1a, rng2a)
rng.Copy
Range("A2").End(xlDown).Offset(1,0).PasteSpecial xlPasteValues
Next
I have raw data which has a large number of columns. I want to extract cells in the first row which begin with Sum_Pop, for example Sum_Pop2_3,N,. I then want to input these strings into a summary sheet in row 4, starting at column 5. Can anybody help me with some VBA code for this problem?
The raw data has roughly 160 columns, and I only want to extract about 10-20 cells. I then want them to input onto the analysis sheet in order, so there are not any gaps between the cells, so it will create headers for yearly increase of population for each row.
I've attempted to use this code:
Private Sub ()
Dim qq As Integer
Dim I As Integer
For qq = 5 To 25
For I = 1 To 200
If Sheets("raw").Range("A" & I) Like "Sum_Pop*" Then
Sheets("raw").Range("A" & I) = Sheets("analysis").Range("R4C" & qq).Value
Else:
Next I
End If
Next qq
Next I
End Sub
Sub Macro1()
Dim ws as Worksheet, LastCol as Long, i as Long, MySel as Range
Set ws = ThisWorkbook.Sheets("raw")
With ws
LastCol= .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 1 to LastCol
If .Cells(1, i) Like "Sum_Pop*" Then
If MySel Is Nothing Then
Set MySel = .Cells(1, i)
Else
Set MySel = Union(MySel, .Cells(1, i))
End If
End If
Next i
End With
If Not MySel Is Nothing Then MySel.Copy _
Destination:=ThisWorkbook.Sheets.Add.Range("E4")
End Sub
I am trying to write a macro that hides the row if the cell value equals the next visible cell in that column and loops through the whole column. I have read that SpecialCells(xlCellTypeVisible) only works up to 8192 cells and my spreadsheet has 15,000 rows.
I have tried something like this but want to restrict it to only visible cells
Sub Test()
For i = 7 To 15258
If Range("P" & i).Value = Range("P" & i + 1).Value Then
Rows(i).Hidden = True
End If
Next i
End Sub
I have tried to search for a solution but haven't been able to find one yet.
Thanks!
I'd be surprised if this couldn't be optimized just a little bit, but it will work for what you are needing.
You can follow the comments within the code itself to kind of get a sense of what it's doing, but in a nutshell, you are using a For...Next statement to loop through your visible cells. For each visible cell, you will search for the next visible cell and then check to see if that matches. If it does, you add that cell to a special range that tracks all the rows to hide at the end of the code, then hide it.
Sub Test()
Dim ws As Worksheet, lookupRng As Range, rng As Range, lstRow As Long
Set ws = ThisWorkbook.Worksheets(1)
lstRow = 15258
Set lookupRng = ws.Range("P7:P" & lstRow)
Dim rngToHide As Range, i As Long
For Each rng In lookupRng.SpecialCells(xlCellTypeVisible)
Application.StatusBar = "Checking row " & rng.Row & " for matches."
For i = rng.Row + 1 To lstRow 'Loop through rows after rng
If Not ws.Rows(i).Hidden Then 'Check if row is hidden
If rng.Value = ws.Cells(i, "P") Then 'check if the non-hidden row matches
If rngToHide Is Nothing Then 'Add to special range to hide cells
Set rngToHide = ws.Cells(i, "P")
Else
Set rngToHide = Union(rngToHide, ws.Cells(i, "P"))
End If
End If
Exit For 'Exit the second For statement
End If
Next i
Next rng
Application.StatusBar = "Hiding duplicate rows"
If Not rngToHide Is Nothing Then rngToHide.EntireRow.Hidden = True
Application.StatusBar = False
End Sub
*EDIT
Here is what ended up kind of working. The solutions below do not run the AddProj when new row is inserted.
Sub Worksheet_Calculate()
Dim X As Range
Set X = LastCell 'The X is superflous, you could just use the LastCell variable
If Sheet5.Range("A" & Rows.Count).Value < X.Value Then
X.Value = Me.Range("A" & Rows.Count).Value
AddProj
End If
End Sub
Module 1 contains the following:
Function LastCell() As Range
With Sheet5
Set LastCell = .Cells(Rows.Count, 1).End(xlUp)
End With
End Function
Sub AddProj()
Sheet1.Range("Master").Copy Sheet1.Range("C" & Rows.Count).End(xlUp).Offset(1)
End Sub
I am trying to read the data in the last cell of a column.
The value of "X" should be the value of this last cell.
I then want "X" to be compared to the number of rows and if the number of rows is less than "X", perform my macro "AddProj".
Once "X" and Column A are the same value, nothing else is to be done.
For some reason, it is not working.
This code is on the worksheet where I want the comparison to be made.
Please see my code below:
Private Sub Worksheet_Calculate()
X = LastCell
If Sheet5.Range("A" & Rows.Count).Value < Sheet5.Range("X").Value Then
Sheet5.Range("X").Value = Me.Range("A" & Rows.Count).Value
AddProj
End If
End Sub
Sub LastCell()
Range("A1").End(xlDown).Select
End Sub
The "AddProj" is a module that is referenced in the code above (thank you #jsheeran #SJR ACyril for help):
Sub AddProj()
Sheet1.Range("Master").Copy Sheet1.Range("C" & Rows.Count).End(xlUp).Offset(1)
End Sub
Thanks in advance.
Try this:
Sub Worksheet_Calculate()
Dim lRow As Long
lRow = Sheet5.Cells(Sheet5.Rows.Count, 1).End(xlUp).Row
If Sheet5.Cells(lRow, 1) > lRow Then
Sheet5.Cells(lRow, 1) = lRow
AddProj
End If
End Sub
X is a variable but you refer to it as "X". Also avoid using .Select as it is not necessary and even in this case just does nothing, because first of all a Sub cannot return a value and second .Select has also no return value. The best way to calculate the last row is this: Sheet5.Cells(Sheet5.Rows.Count, 1).End(xlUp).Row
Here is just a slight variation on UPGs great answer.
Dim lRow As Long
lRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
If lRow >= Sheet1.Cells(lRow, 1) Then
Exit Sub
Else: AddProj
End If
I have code to archive data from "sheet1" to "sheet2". It overwrites existing data in the "sheet2" rows from the previous archive exercise.
How do I have it seek the next blank row vs. overwriting existing data?
I have two header rows so it should commence with row 3.
Option Explicit
Sub Archive()
Dim lr As Long, I As Long, rowsArchived As Long
Dim unionRange As Range
Sheets("sheet1").Unprotect Password:="xxxxxx"
Application.ScreenUpdating = False
With Sheets("sheet1")
lr = .Range("A" & .Rows.Count).End(xlUp).Row
For I = 3 To lr 'sheets all have headers that are 2 rows
If .Range("AB" & I) = "No" Then
If (unionRange Is Nothing) Then
Set unionRange = .Range(I & ":" & I)
Else
Set unionRange = Union(unionRange, .Range(I & ":" & I))
End If
End If
Next I
End With
rowsArchived = 0
If (Not (unionRange Is Nothing)) Then
For I = 1 To unionRange.Areas.Count
rowsArchived = rowsArchived + unionRange.Areas(I).Rows.Count
Next I
unionRange.Copy Destination:=Sheets("sheet2").Range("A3")
unionRange.EntireRow.Delete
End If
Sheets("sheet2").Protect Password:="xxxxxx"
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Operation Completed. Total Rows Archived: " & rowsArchived
End Sub
Change
unionRange.Copy Destination:=Sheets("sheet2").Range("A3")
... to,
with worksheets("sheet2")
unionRange.Copy _
Destination:=.Cells(.rows.count, 1).end(xlup).offset(1, 0)
end with
This is like starting at the bottom row of the worksheet (e.g. A1048576) and tapping [ctrl+[↑] then selecting the cell directly below it.
The With ... End With statement isn't absolutely necessary but it shortens the code line enough to see it all without scolling across. unionRange has been definied by parent worksheet and cell range so there is no ambiguity here.
I'd propose the following "refactoring"
Option Explicit
Sub Archive()
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht1 = Sheets("sheet1")
Set sht2 = Sheets("sheet2")
sht1.Unprotect Password:="xxxxxx"
With sht1.Columns("AB").SpecialCells(xlCellTypeConstants).Offset(, 1) '<== change the offset as per your need to point to whatever free column you may have
.FormulaR1C1 = "=if(RC[-1]=""NO"","""",1)"
.Value = .Value
With .SpecialCells(xlCellTypeBlanks)
.EntireRow.Copy Destination:=sht2.Cells(sht2.Rows.Count, 1).End(xlUp).Offset(1, 0)
MsgBox "Operation Completed. Total Rows Archived: " & .Cells.Count
End With
.ClearContents
End With
sht2.Protect Password:="xxxxxx"
End Sub
just choose a "free" column in "Sheet1" to be used as a helper one and that'll be cleared before exiting macro. In the above code I assumed it's one column to the right of "AB"
The following approach worked for me! I'm using a button to trigger macro.
Every time it takes the last row and append it to new sheet like a history. Actually you can make a loop for every value inside your sheet.
Sub copyProcess()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim source_last_row As Long 'last master sheet row
source_last_row = 0
source_last_row = Range("A:A").SpecialCells(xlCellTypeLastCell).Row
Set copySheet = Worksheets("master")
Set pasteSheet = Worksheets("alpha")
copySheet.Range("A" & source_last_row, "C" & source_last_row).copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub