http://i.stack.imgur.com/eBcT5.jpg
I want to create two different ranges, one for everything on the left (column A) of the Ss in column B, and one for everything on the left of the Fs in column B. (see picture)
lastRowA = ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Row
Sub Test2()
Dim rngs As Range
Dim rngf As Range
Dim onleft As Range
i = 1
Do Until i = lastRowA
Cells(i, 2).Activate
Select Case ActiveCell
Case Is = "s"
Set onleft = Cells(i, 1)
Set rngs = Application.Union(rngs, onleft) '<error message for this line
Case Is = "f"
Set onleft = Cells(i, 1)
Set rngf = Application.Union(rngf, onleft)
Case Else
Range("D1").Value = ":("
End Select
i = i + 1
Loop
rngs.Font.Color = RGB(123, 0, 123)
rngf.Font.Color = RGB(255, 0, 0)
End Sub
I would appreciate any adjustments to the code used, or any different ways of going about this problem...
The error I get is :"Invalid procedure call or arguement", Run time error 5.
I didn't use the autofilter because my motive is to use the range to count the numbers. I want to change the colours as a test to see if the code works.
The issue is that, initially, rngs and rngf are Nothing, meaning it is empty and does not refer to a range. When you try to Union the range onleft with Nothing (rngs or rngf) you get the error. The following code solves that problem:
Sub Test2()
Dim rngs As Range
Dim rngf As Range
Dim onleft As Range
lastRowA = ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Row
i = 1
Do Until i = lastRowA
Cells(i, 2).Activate
Select Case ActiveCell
Case Is = "s"
Set onleft = Cells(i, 1)
If rngs Is Nothing Then
Set rngs = onleft 'The first time through, rngs is nothing, so set it equal to onleft
Else
Set rngs = Application.Union(rngs, onleft) 'subsequent times, the onleft is unioned with rngs
End If
Case Is = "f"
Set onleft = Cells(i, 1)
If rngf Is Nothing Then
Set rngf = onleft 'same thing here...
Else
Set rngf = Application.Union(rngf, onleft) '...and here
End If
Case Else
Range("D1").Value = ":("
End Select
i = i + 1
Loop
rngs.Font.Color = RGB(123, 0, 123)
rngf.Font.Color = RGB(255, 0, 0)
End Sub
Related
I have a range of cells which I'm scanning if the cell has a formular or not.
When it does, I want to save the column letters and row numbers i.e. E14, E18, F18, N18 (Reference) do a dictionary.
Once I've looped through my specific range, I want to select the cells saved in the dictionary to later on delete all cells with formulas in the selected cells.
I am stuck with the part to safe the cell reference to the dictionary.
The range in the example is just an example range.
Sub check_formula_empty()
Dim cell As Range
Dim i As Integer
Dim rng As Range
Set rng = Range("E13:N19")
For i = 1 To rng.Cells.Count
If rng.Cells(i).HasFormula = True And rng.Cells(i).Offset(-6, 0) = "A" Then
'save reference range to Dictionary
ElseIf rng.Cells(i).HasFormula = False And rng.Cells(i).Offset(-6, 0) = "F" Then
rng.Cells(i).Offset(-4, 0).Copy _
Destination:=rng.Cells(i)
End If
Next
'Here I want to run the "Select my saved range from the Dictionary" and run "delete formulas"
End Sub
You can us a collection for this purpose. You are mentioning a dictionary but for your purpose a key is not that important, you only need a list of items (collection supports both)
Sub check_formula_empty()
Dim cell As Range
Dim i As Integer
Dim rng As Range
Set rng = Range("E13:N19")
dim reflist as Collection
Set reflist = new Collection
For i = 1 To rng.Cells.Count
If rng.Cells(i).HasFormula = True And rng.Cells(i).Offset(-6, 0) = "A" Then
'save reference range to Dictionary
refList.Add rng.Cells(i)
ElseIf rng.Cells(i).HasFormula = False And rng.Cells(i).Offset(-6, 0) = "F" Then
rng.Cells(i).Offset(-4, 0).Copy _
Destination:=rng.Cells(i)
End If
Next
'Here I want to run the "Select my saved range from the Dictionary" and run "delete formulas"
Dim oneCell as Range
foreach oneCell in refList
oneCell.Value = vbEmpty
next
End Sub
As you can see we first add the complete cell to the collectdion (it is a referenced object) and later you can use it in the foreach loop to your liking with all its properties
So I was working on resolving the issue to run the VBA faster than looping 2-3x through each column.
My current issue, which I struggle to resolve is: that the defined range "nof" or "DBRW" keeps to increase, which when resolving my final code (delete or copy formula to the Union ranges), the whole Union ranges are selected and therefore formulars are overwritten for the full range, instead of looping from column to column and using the defined formula in that column, which is available in a fixed row (Cells(6, n)).
Option Explicit
Sub Test3()
Dim i As Integer
Dim n As Integer
Dim x As Integer
Dim DBRW As Range
Dim DBRWrange(1 To 32) As Range
Dim nof As Range
Dim nofRange(1 To 32) As Range
Dim rangef As Range
For n = 5 To 6
For i = 13 To 20
If Cells(i, n).HasFormula = True And Cells(7, n) = "A" Then
Set DBRWrange(i) = Cells(i, n)
If DBRW Is Nothing Then
Set DBRW = DBRWrange(i)
Else
Set DBRW = Union(DBRW, DBRWrange(i))
End If
ElseIf Cells(i, n).HasFormula = False And Cells(7, n) = "F" Then
Set nofRange(i) = Cells(i, n)
If nof Is Nothing Then
Set nof = nofRange(i)
Else
Set nof = Union(nof, nofRange(i))
End If
End If
Next i
Set rangef = Cells(6, n)
rangef.Copy nof
'Ranges in nof and DBRW are kept (incremented), is there a way to "refresh" the Union reference, to restart creating the range from after this step?
Next n
End Sub
ยดยดยด
so I have solved my issue and for future googlers, this might be helpful :)
Public Sub copy_paste_delete()
Dim i As Integer
Dim n As Integer
Dim DBRW As Range
Dim DBRWrange(1 To 150) As Range
Dim nof As Range
Dim nofRange(1 To 150) As Range
Dim rangef As Range
Application.ScreenUpdating = False
Worksheets("Tab1").Activate
Range("K29").Select
Set DBRW = Nothing
Set nof = Nothing
For n = 61 To 75
Set nof = Nothing
Set DBRW = Nothing
For i = 33 To 38
If Cells(i, n).HasFormula = True And Cells(6, n) = "F" Then
Set DBRWrange(i) = Cells(i, n)
If DBRW Is Nothing Then
Set DBRW = DBRWrange(i)
Else
Set DBRW = Union(DBRW, DBRWrange(i))
End If
ElseIf Cells(i, n).HasFormula = False And Cells(6, n) = "A" And Cells(7, n) = "Done" Then
Set nofRange(i) = Cells(i, n)
If nof Is Nothing Then
Set nof = nofRange(i)
Else
Set nof = Union(nof, nofRange(i))
End If
End If
Next i
Set rangef = Cells(19, n)
On Error Resume Next
rangef.Copy nof
Next n
DBRW.Select
'Do some stuff
Application.ScreenUpdating = True
End Sub
I have a spreadsheet that I'm trying to migrate into SQL.
The spreadsheet contains 65k rows of information over two worksheets.
The people operating the spreadsheet have been colouring the font in the rows either red, blue or yellow depending on the status of the record. Each row is a record with personal data etc. so I can't share online.
As part of the migration to SQL I need to add a column with a status field. The status field on each row should contain either 1, 2, 3, or 4 depending on whether the row has a black, red, blue or yellow font.
Based on searching here I believe it might be possible with a VBA function and a formula?
Could anyone help with what to do? I'm ok with Excel but not a power user by any means.
try using something like this in VBA. You will need to add several more ifs based on the colors you have.
CurrentSheetText="Sheet1"
LastRow = Sheets(CurrentSheetText).Cells.SpecialCells(xlCellTypeLastCell).Row
for iter = 1 to LastRow
if Sheets(CurrentSheetText).Cells(iter, 1).Interior.Color = RGB(255, 255, 0) Then
Sheets(CurrentSheetText).Cells(iter,5).value =1
End if
Next iter
This is very easily implemented with VBA. Due to the lack of information in the post, I can only write you a crude script
Sub AddCol()
Dim wb As Workbook
Dim ws As Worksheet
Dim LRow As Long, i As Long
'Target workbook
Set wb = Workbooks("NAME")
'Target worksheet
Set ws = wb.Sheets(INDEX)
'Target column
target_col = 1
'Output column
output_col = 10
With ws
'Find last row in sheet based on column A
LRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop through row 1 through LRow
For i = 1 To LRow
'populate output col based on target col's font colour
If .Cells(i, target_col).Font.Color = vbBlack Then
.Cells(i, output_col).Value = 1
ElseIf .Cells(i, target_col).Font.Color = vbRed Then
.Cells(i, output_col).Value = 2
ElseIf .Cells(i, target_col).Font.Color = vbBlue Then
.Cells(i, output_col).Value = 3
ElseIf .Cells(i, target_col).Font.Color = vbYellow Then
.Cells(i, output_col).Value = 4
End If
Next i
End With
End Sub
Many thanks for all the help!
It seems there is a very simple way to do this without any code!
I was able to use the filter function by highlighting the cheet and sorting by colour. Once I had all the red text together I was able to just add a 1 to each row and fill down.
Try the next function, please. It will return an array with the settled codes for analyzed colors. It take in consideration all standard nuances (especially for blue) of the colors in discussion:
Function colorNo(sh As Worksheet) As Variant
Dim lastR As Long, cel As Range, arr, k As Long
lastR = sh.Range("A" & rows.count).End(xlUp).row
ReDim arr(lastR - 2)
For Each cel In sh.Range("A2:A" & lastR)
Select Case cel.Font.Color
Case vbRed, 49407: arr(k) = 2: k = k + 1
Case vbBlue, 12611584, 6567712, 9851952, 14395790: arr(k) = 3: k = k + 1
Case vbYellow: arr(k) = 4: k = k + 1
Case Else: arr(k) = 1: k = k + 1
End Select
Next
colorNo = arr
End Function
The above code considers all other colors like being Black!
If in the future you will need some other colors, you should fill appropriate Case newColor lines...
It can be tested/used in this way:
Sub testColorNo()
Dim sh As Worksheet, arrCol As Variant
Set sh = ActiveSheet
arrCol = colorNo(sh)
'the array can be used like it is
'or its value can be dropped in the last empty column
'un comment the next line if you want to visually see the returned array
'but only on testing small range. Otherwise, it will be a huge string...
'Debug.Print Join(arrCol, ","): you can see the array content in Immediate Window
sh.cells(2, sh.UsedRange.Columns.count + 1).Resize(UBound(arrCol) + 1, 1).Value = _
WorksheetFunction.Transpose(arrCol)
End Sub
This should work:
Sub SubColor()
'Declarations.
Dim RngColouredRange As Range
Dim RngFirstAnswer As Range
Dim RngTarget As Range
Dim DblRow As Double
'Setting variables.
Set RngColouredRange = Range("M1:M5")
Set RngFirstAnswer = Range("N1")
'Covering each cell in RngColouredRange.
For Each RngTarget In RngColouredRange
'Checking font's color.
Select Case RngTarget.Font.Color
'In Case is black.
Case Is = 0
RngFirstAnswer.Offset(DblRow, 0) = 0
'In case is red.
Case Is = 255
RngFirstAnswer.Offset(DblRow, 0) = 1
'In case is blue.
Case Is = 12611584
RngFirstAnswer.Offset(DblRow, 0) = 2
'In case is yellow.
Case Is = 65535
RngFirstAnswer.Offset(DblRow, 0) = 3
'In other cases.
Case Else
RngFirstAnswer.Offset(DblRow, 0) = "Unclassified"
End Select
'Increasing DblRow.
DblRow = DblRow + 1
Next
End Sub
Edit the variables accordingly.
If you need to know what number refers to each of the fonts' color you have, use this:
Sub SubFontColourNumber()
'Declarations.
Dim RngColouredRange As Range
Dim RngFirstAnswer As Range
Dim RngTarget As Range
Dim DblRow As Double
'Setting variables.
Set RngColouredRange = Range("M1:M5")
Set RngFirstAnswer = Range("N1")
'Covering each cell in RngColouredRange.
For Each RngTarget In RngColouredRange
'Reporting the font's color.
RngFirstAnswer.Offset(DblRow, 0) = RngTarget.Font.Color
'Increasing DblRow.
DblRow = DblRow + 1
Next
End Sub
Like before, edit the variables accordingly.
I am trying to compare two Range and copy data based on IF and AND condition, but AND condition is not working as a result data is being copied only based on IF condition. Please suggest what change should I make in code. Below is Code which I am currently using:
Sub Copy3()
Dim mCell As Range
Dim yRange As Range
Dim mRange As Range
Dim RRange As Range
Set mRange = Worksheets("Sheet2").Range("DB2:DB17")
Set yRange = Worksheets("Sheet2").Range("CZ2:CZ17")
Set RRange = Worksheets("Sheet2").Range("CY2:CY17")
Set target = mRange.Offset(columnoffset:=-3)
Dim P As Long, Q As Long, t As Long
For P = 1 To mRange.Cells.Count
For Q = 1 To RRange.Cells.Count
For t = 1 To yRange.Cells.Count
If mRange.Cells(P).Value <> "" And RRange.Cells(Q).Value <> yRange.Cells(t).Value Then
mRange.Cells(P).Copy target.Cells(P)
End If
Next
Next
Next
End Sub
you can try this (the sheet name and ranges must be changed to reflect the structure of your data). I made the assumption that target points to column A. The address of the cells is traced to make it easier to check if this is in deed what you expect the code to do.
Dim wholeRange As Range
Set wholeRange = Worksheets("Feuil1").Range("A2:D17")
If (Not wholeRange Is Nothing) Then
Dim row As Range, rP As Range, rQ As Range, rR As Range, rT As Range
For Each row In wholeRange.Rows
Set rP = row.Offset(0, 1).Resize(1, 1)
Set rR = row.Offset(0, 2).Resize(1, 1)
Set rQ = row.Offset(0, 3).Resize(1, 1)
Set rT = row.Offset(0, 0).Resize(1, 1)
Debug.Print "P:" + rP.Address + " R:" + rR.Address + " Q:" + rQ.Address + " T:" + rT.Address
If (rP.Cells(1, 1).Value <> "") And (rQ.Cells(1, 1).Value <> rT.Cells(1, 1).Value) Then
rP.Cells(1, 1).Value = rT.Cells(1, 1).Value
End If
Next row
Else
Debug.Print "wholeRange range is not defined"
End If
I'm interested in a macro that will add a value in column P (Pass, At Risk or Failed) if column A has a certain condition - see below example.
I wonder if below macro can be used as inspiration. It was created to color a row if certain condition is met.
I'd also like the new macro to assign certain cell color in column P for value: Green for Pass, Yellow for At Risk and Red for Failed (same colors as in below macro)
Option Explicit
Sub Stackoverflow()
Dim ws As Worksheet
Dim rows As Long, i As Long
Dim rngSearch As Range, rngColor As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Set ws = ActiveSheet
rows = ws.UsedRange.rows.Count
For i = 1 To rows
Set rngSearch = ws.Cells(i, 1)
Set rngColor = ws.Range("A" & i, "O" & i)
If rngSearch = "Unexpected Status" Then
rngColor.Interior.Color = 13434828
End If
If rngSearch = "At Risk" Then
rngColor.Interior.Color = 8420607
End If
If rngSearch = "Requirements Definition" Then
rngColor.Interior.Color = 10092543
End If
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
This would make column P yellow, if rngSearch is "At Risk":
For i = 1 To rows
Set rngSearch = ws.Cells(i, 1)
Set rngColor = ws.Range("A" & i, "O" & i)
If rngSearch = "Unexpected Status" Then
rngColor.Interior.Color = 13434828
End If
If rngSearch = "At Risk" Then
Cells(rows, "P").Interior.Color = vbYellow
End If
If rngSearch = "Requirements Definition" Then
rngColor.Interior.Color = 10092543
End If
Next i
The others are to be made correspondingly.
Yes you can, simplified
Dim i As Long, lngColor as Long 'It is inadvisable to declare variables which could also be the name of built in functions and objects, in your case I would not declare "rows" as a variable as it is also a property of an object
Dim varVal as Variant
Dim ws As Worksheet
Set ws = Thisworkbook.Worksheets("Sheet1") 'As general advice, avoid active and select but used fixed values, this way no confusion can exist as to which sheet is used In my example it is Sheet1, but you have to set it to the actual name of your sheet
with ws
For i = 1 To .UsedRange.Rows.Count
Select Case .Cells(i, 1) 'Looks at the value of row i column A, and then below if it matches a case.
Case "Unexpected Status"
varVal = "Pass"
lngColor = 13434828
Case "At Risk"
varVal = "At Risk"
lngColor = 8420607
Case "Requirements Definition"
varVal = "Failed"
lngColor = 10092543
Case else
varVal = Empty
lngColor = 0
End Select
.Cells(i, 16) = varVal 'row i in column P is set to the value determined by the condition in the select case part
If Not lngColor = 0 Then 'This value of lngColor is only present if the select case did not match and if so, the color should not be changed
.Range(.Cells(i, 1), .Cells(i, 16)).Interior.Color = lngColor 'Set the range of row i column A to column P to the color specified by the case select.
End If
Next i
End With
This macro I have written searches the entire page for the values; 0, 1, 2, or 3 and then deletes that row.
Sub delRows()
Dim cl As Range
Dim uRng As Range
Dim rng As Range
Dim x As Long
Set uRng = ActiveSheet.UsedRange
For Each cl In uRng
If cl.Value = "0" Or cl.Value = "1" Or cl.Value = "2" Or cl.Value = "3" Then
If x = 0 Then
Set rng = cl
x = 1
Else: Set rng = Union(rng, cl)
End If
End If
Next cl
rng.EntireRow.Delete
End Sub
How do I change it to scan a single column for those values then delete the row?
I get errors.
Let's say I want to search in Column "J" in the worksheet?
This just requires changing one line in your code:
Set uRng = ActiveSheet.Range("J:J")
To speed things up, you can specify a smaller range, e.g. Range("J1:J100") or wherever your data is. Else you will loop through the entire column, i.e. 65536 rows (Excel 2003) or a million rows (2007 and newer), which is very time consuming.
Sub delRows2()
Application.ScreenUpdating = False
Dim r As Long, r1 As Long, r2 As Long, c As Long
c = 10 '<--- this is the column you want to search
r1 = ActiveSheet.UsedRange.Row
r2 = r1 + ActiveSheet.UsedRange.Rows.Count - 1
For r = r2 To r1 Step -1
If Cells(r, c) = "0" or Cells(r, c) = "1" or Cells(r, c) = "2" or Cells(r, c) = "3" Then Cells(r, 1).EntireRow.Delete
Next r
End Sub