in the following code
Sub SetColorScheme(cht As Chart, i As Long)
Dim y_off As Long, rngColors As Range
Dim x As Long
y_off = i Mod 10
'this is the range of cells which has the colors you want to apply
Set rngColors = ThisWorkbook.Sheets("colors").Range("A1:C1").Offset(y_off, 0)
With cht.SeriesCollection(1)
'loop though the points and apply the
'corresponding fill color from the cell
For x = 1 To .Points.Count
.Points(x).Format.Fill.ForeColor.RGB = _
rngColors.Cells(x).Interior.Color
Next x
End With
End Sub
the range from which the data are read is in th emoment stated in the code. Is there a chance that it is read from asheet in the worksheet? So that a person can enter A1:C1 and it will place it the way it is in the code in the moment?
I'm not sure how you want to handle the user's input, but of course the range can be an incoming variable. I have it below as a string but elegance would be the range object. Sorry if this is too simple, I'm not sure your question.
Sub SetColorScheme(UserRange As String, cht As Chart, i As Long)
...
'this is the range of cells which has the colors you want to apply
Set rngColors = ThisWorkbook.Sheets("colors").Range(UserRange).Offset(y_off, 0)
...
End Sub
If the user enters "A1:C1" in cell D1 then you can make use of this range with:
Set rngColors = ThisWorkbook.Sheets("colors").Range(Range("D1").Value).Offset(y_off, 0)
' but you should refer to the w/sheet as well
Set rngColors = ThisWorkbook.Sheets("colors") _
.Range(ThisWorkbook.Sheets("colors").Range("D1").Value).Offset(y_off, 0)
Range("D1").Value obtains the text "A1:C1" which is then used to identify this Range.
Related
I am trying to copy the style from a specific column (formatted as Text starting from its second row) to another column (formatted as Date starting from its second row). Both columns stores values.
I am able to copy-and-paste the style to the destination column:
.Columns("A").Copy '# "A" is the starting column
.Columns(dest_col).PasteSpecial Paste:=xlPasteFormats '# dest_col is the destination column
but this code also formats it as a Text column, while I want to keep its original formatting (i.e. Date starting from the second row).
Is there any option I can use to prevent this behavior?
You may try to take only the values of the specific parameters, which you are interested in (E.g., style, Interior Color, Font Color etc.)
The following works only when the whole column has the same format, as far as I did not to loop through every cell:
Option Explicit
Sub TestMe()
Dim colFrom As Long
Dim colTo As Long
colFrom = 1
colTo = 5
CopyFullFontAndInterior colFrom, colTo
End Sub
Sub CopyFullFontAndInterior(colFrom As Long, colTo As Long, Optional wsN As Long = 1)
Dim copyFrom As Range
Dim copyTo As Range
With Worksheets(1)
Set copyFrom = .Range(.Cells(1, colFrom), .Cells(2 ^ 20, colFrom))
Set copyTo = .Range(.Cells(1, colTo), .Cells(2 ^ 20, colTo))
End With
copyTo.Style = copyFrom.Style
If copyFrom.Interior.Color > 0 Then copyTo.Interior.Color = copyFrom.Interior.Color
If copyFrom.Font.Color > 0 Then copyTo.Font.Color = copyFrom.Font.Color
End Sub
A possible workaround is to save the format of a given cell of the column in a variable and to use it after the .PasteSpecial:
Sub TestMe()
Dim saveOurFormat As String
saveOurFormat = Columns(5).Cells(2).NumberFormat
Columns("A").Copy
Columns(5).PasteSpecial Paste:=xlPasteFormats
Columns(5).NumberFormat = saveOurFormat
Application.CutCopyMode = False
End Sub
I have the following method which finds the largest and smallest values in a range. I am then using those values to locate the actual cell they are in as I need to grab the value from the header cell of that column. The Range.Find is always returning Nothing even though the range being searched HAS A CELL WITH THAT VALUE.
Sub GetTopAndBottomFiveCommodities()
Dim tempRange As Range, x As Integer, bestPnL As Double, worstPnL As Double
Dim strTopRangeName As String, strBottomRangeName As String
Dim cCell As Range, commodityName As String
Set tempRange = dataSourceSheet.Range("A:A").Find(What:="Year Totals")
Set tempRange = Range(tempRange.Offset(0, 1), tempRange.End(xlToRight).Offset(0, -1))
For x = 1 To 5
strTopRangeName = "TopCommodity" & CStr(x)
strBottomRangeName = "BottomCommodity" & CStr(x)
bestPnL = WorksheetFunction.Large(tempRange, x)
worstPnL = WorksheetFunction.Small(tempRange, x)
Debug.Print tempRange.Address
' get the top commodity name and PnL
**Set cCell = tempRange.Find(What:=bestPnL, LookIn:=xlValues)**
commodityName = dataSourceSheet.Cells(5, cCell.Column).Value
Range(strTopRangeName).Value = commodityName
Range(strTopRangeName).Offset(0, 1).Value = bestPnL
Next x
End Sub
The code line
Set cCell = tempRange.Find(What:=bestPnL, LookIn:=xlValues)
is always returning nothing but I have verified that there are cells with that value. One example, the cell value is 66,152.61 (displayed in cell as 66,153) and the bestPnL variable is 66,152.61 , so I tried rounding bestPnL to 66,153, but still didn't find it. The debug statement is showing tempRange has the right range, so its not searching in the wrong place.
The only thing I can think of is the cell with the value, gets its value from a very long formula, using over a dozen named ranges, can this be fouling the find method?
Just so we all know I'm not crazy, here is a snapshot of part of the range I'm searching where I'm testing.
EDIT
Based on Tim Williams suggestion, I changed the number format of the range being searched prior to the Find call.
tempRange.NumberFormat = "0.00"
and then the Find call works as it should. I then just put the number format back the way I want it at the end of the routine.
tempRange.NumberFormat = "$#,##0;[Red]$#,##0"
Works as expected now.
Try removing the thousand separator from the number format on the cells. When I did that in a test range it worked fine, but with the separator it failed to find the value.
Set f = rng.Find(what:=bestPnL, LookIn:=xlFormulas)
will work even with the thousand separator (EDIT: only works with hard-coded values; fails with formulas).
EDIT2: this worked for me with a thousands separator and using formulas for the values (EDIT3!: does not work with currency formatting).
Sub Tester()
Dim f As Range, v, rng As Range
Set rng = Range("C3:C21")
v = Application.Large(rng, 3)
v = Format(v, rng.Cells(1).NumberFormat)
Set f = rng.Find(what:=v, LookIn:=xlValues)
Debug.Print f.Address ' >> C19
End Sub
This is an old question, but I found an alternative that can be effective and simple in some situations:
dim idx as long, rng as range
set rng = someRange
idx = application.WorksheetFunction.Match(1234,rng,0)
This will return the relative position of the FIRST 1234 valued cell in the provided range, independently of the formatting. The last 0 means you use an exact match.
Following my previous question:
Background Color based on difference with cell
. I would now like to apply this function to a range of rows.
The function I'd like to apply is:
If Sheets("X").Range("E18") > Sheets("blocked(R)").Range("D18") Then
Sheets("X").Range("E18").Interior.ColorIndex = 10
The range I need to apply this function to is fixed: D18:E1200.
However, there will be an active filter on this range.
The Autofill code of course is not working and writing a line of code for each of 1200 rows would be crazy.
I have been searching and reading and I think it must be something like:
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("A1:C2")
For Each row In rng.Rows
For Each cell in row.Cells
'Do Something
Next cell
Next row
But I don't seem to get it to work, I was hoping for some pointing into the right direction of the community.
Sub test()
Dim rngApply As Range
Set rngApply = Sheets("X").Range("D18:E1200")
Dim varIndex As Variant
For Each varIndex In rngApply
If varIndex.Value > Sheets("blocked(R)").Range("D18") Then
varIndex.Interior.ColorIndex = 10
End If
Next
End Sub
I'm trying to figure out a way to compare one cell in Sheet2 vs. an entire row in Sheet1. If there is a match then I'd like to mark a requested row with an "X". The row to mark the "X" with needs to change because I'm comparing for numerous users, I figure I can just set a string for input. Once the single cell has checked down the entire row, I'd need the next cell in the column to check against the entire row and mark an "X" accordingly.
The long short of this is I'm making a database of software installed on 50 computers and I have a list of all possible applications and all installed applications per computer. Not every computer has every application, so I'm trying to automate a spreadsheet that will mark which computers have which software based on the data gathered. If this doesn't make sense please let me know. I understand logic flow and program in Powershell often but I'm not too familiar with VBA commands. Thank you!
Edit: Added picture for explanation.
Edit2: Added code below that I have. It seems to run the check but the c.Value is always wrong. It just doesn't quite check out. I tested CellApp.Select to confirm the range I want is correct. The loop just isn't checking the right values I don't think. For the example picture, pretend that the "List of Machine 3's Programs" is on Sheet2 and starts at A1.
Option Explicit
Sub check()
Dim wsApplications As Worksheet, wsMachines As Worksheet
Dim CellApp As Range, CellMachine As Range
Dim listStRow As Long, listEndRow As Long, listCol As Long
Dim c As Range
Dim Counter As Integer
Set wsApplications = Sheets("Sheet2")
Set wsMachines = Sheets("Sheet1")
Counter = 3
'data start(row, col)on machines-list sheet
listStRow = 2
listCol = 1
With wsApplications
'find last machine in list
listEndRow = .Cells(Rows.Count, listCol).End(xlUp).Row
'Set CellApp Range
Set CellApp = Range("A2", Cells(listEndRow, 1))
For Each c In CellApp.Cells
'For each cell in the CellApp Range...
Set CellMachine = Cells(1, Counter)
Counter = Counter + 1
'Defines CellMachines as Cell "1,3" then "1,4" then "1,5" etc...
If c.Value = CellMachine.Value Then
'If the cell in CellApp is equal to the cell that is currently CellMachine
wsMachines.Cells(4, CellMachine.Column).Value = "X"
'Mark an X underneath the column that matches up. Designated Row 4 for a test.
End If
Next c
End With
One method outlined below. This assumes that the mc/program data is presented as per the image below and your 'matrix' is presented as per your Q. Adjust the sheet names and data positions in the code to suit.
Option Explicit
Sub check()
Dim wsList As Worksheet, wsMatrix As Worksheet
Dim r As Range, c As Range
Dim listStRow As Long, listEndRow As Long, listCol As Long, n As Long
Dim matHdr As Long, matCol As Long
Dim mcNo As String, progNo As String
Set wsList = Sheets("Sheet2")
Set wsMatrix = Sheets("Sheet1")
'data start(row, col)on machines-list sheet
listStRow = 2
listCol = 1
'start position of matrix (row, col) to be filled
matHdr = 1
matCol = 1
With wsList
'find last machine in list
listEndRow = .Cells(Rows.Count, listCol).End(xlUp).Row
'for each mc in list
For n = listStRow To listEndRow
'construct matrix intersect 'headers' for mc and program
mcNo = "Machine " & CStr(.Cells(n, listCol).Value)
progNo = "Program " & CStr(.Cells(n, listCol).Offset(0, 1).Value)
'populate matrix with "X"
With wsMatrix
Set r = .Columns(matCol).Find(mcNo, , , xlWhole)
If Not r Is Nothing Then
Set c = .Rows(matHdr).Find(progNo, , , xlWhole)
If Not c Is Nothing Then
Intersect(r.EntireRow, c.EntireColumn) = "X"
End If
End If
End With
Next n
End With
End Sub
I wanted to use this code
Sub PieMarkers()
Dim chtMarker As Chart
Dim chtMain As Chart
Dim intPoint As Integer
Dim rngRow As Range
Dim lngPointIndex As Long
Dim x As Long
Dim myTheme As String
Application.ScreenUpdating = False
Set chtMarker = ActiveSheet.ChartObjects("chtMarker").Chart
Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart
Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart
Set rngRow = Range(ThisWorkbook.Names("PieChartValues").RefersTo)
For Each rngRow In Range("PieChartValues").Rows
chtMarker.SeriesCollection(1).Values = rngRow
SetColorScheme chtMarker, x
chtMarker.Parent.CopyPicture xlScreen, xlPicture
lngPointIndex = lngPointIndex + 1
chtMain.SeriesCollection(1).Points(lngPointIndex).Paste
x=x+1
Debug.Print rngColors.address()
Next
lngPointIndex = 0
Application.ScreenUpdating = True
End Sub
Sub SetColorScheme(cht As Chart, i As Long)
Dim y_off As Long, rngColors As Range
Dim x As Long
y_off = i Mod 13
'this is the range of cells which has the colors you want to apply
Set rngColors = ThisWorkbook.Sheets("Basic").Range(ThisWorkbook.Sheets("Basic").Range("A19").Value).Offset(y_off, 0)
With cht.SeriesCollection(1)
'loop though the points and apply the corresponding fill color from the cell
For x = 1 To .Points.Count
.Points(x).Format.Fill.ForeColor.RGB = _
rngColors.Cells(x).Interior.Color
Next x
End With
End Sub
to colour several pie charts with all of them having the same amount of slices (3 each, 8 pie charts) according to specified colours in the workbook (colours used as background colour for a cell in a worksheet).This is the Sub Colour Scheme.
The code compiles without error the problem is just that it only uses the first to specified colours in a range (say A10:Z10, only the colours in A10 and B10 to colour all pieces of the 8 pie charts (24 sclices in total with the two colours from A10 and B10). Could somebody tell me what I would need to change so that the whole colour range from A10 to X10 is used (24 different colours) for the different slices?
It seems the For loop that use cht.SeriesCollection(1).Points.Count as a boundary doesn't take you beyond two iterations.
You should rather use an inner loop specific to the range of cells you want to retrieve the color from and a if condition statement if there are less colors.