I just finished building a chess game on excel by VBA for my school project.
The way I built it is every piece has a number and a color (Green/Red):
1 - Pawn (x16)
2 - King (x2)
3 - Queen (x2)
4 - Bishop (x4)
5 - Night (x4)
6 - Rook (x4)
Just so it will look nicer I wanted to add pictures of each piece that will follow the number, Or that will move by a VBA commend that will come with the commend of moving the piece.
I prefer the first option if possible but the second one is good as well.
The way I move the pieces right now is like that:
MoveNum = Range(Range("j2").Value).Value
Range(Range("j2").Value).Value = 0
Range(Range("j2").Value).FormulaR1C1 = ""
Range(Range("j2").Value).Font.Color = -0
Range(Range("k2").Value).Value = MoveNum
Range(Range("k2").Value).Font.Color = RGB(210, 0, 0)
(This is the one that moves red pieces, the only difference between it and the green is that the RGB is (0, 175, 20) and not (210, 0, 0)
BTW my entire code is based on the numbers so changing/not using them isn't an option.
A time-saving alternative could be to use Unicode characters, instead of images:
♔♕♖♗♘♙♚♛♜♝♞♟
These are Unicode 9812 to 9823 and you can add them to Excel using either the UNICHAR worksheet function, or the ChrW function in VBA.
Also, you could just copy and paste them from above, right into your worksheet, and then manipulate them like you would any other text, including font size.
Here's the knight at 80pt:
My preferred place to look when I need a symbol or icon is (or to identify one) is https://codepoints.net. As of March 2019, Unicode contains almost 140,000 characters, with more being constantly added.
(Be sure to sign the petition to have a pot-leaf emoji added!) 🍁🍂🌿🍃🍀
If your assignment specifically requires you to use images then you can:
move the images with the .Top and .Left properties of the Shapes object
find the position of the cell with the .Top and .Left properties of the Range object.
Example:
Option Explicit
Sub movePicToCell()
'move the image named "Picture 2" on worksheet "Sheet1" to cell "C3"
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Shapes("Picture 2").Top = ws.Range("C3").Top
ws.Shapes("Picture 2").Left = ws.Range("C3").Left
End Sub
Related
I have built a heat map of the UK. Is it possible to have a certain county highlighted when a cell has the same name as the county?
The Heat Map is made of individual Pictures per County, which have been overlapped. Ideally this would take effect as soon as you finished putting data into the cell.
I understand that Conditional Formatting is unlikely to work, and this will probably require VBA - also, when I try to apply an outline it is currently around the Picture rectangle instead of just the non-transparent part of the image.
Please ask me any questions if you need more info.
Thanks
Rather than use Line, use Glow or Shadow, with a low-or-zero Transparency. For example the following 2 subs will make a Shape called "Picture 1" on Sheet1 start or stop glowing with 0 transparency, which will hopefully give a suitable outline.
Sub MakeShapeGlow()
With Sheet1.Shapes("Picture 1").Glow
.Color.ObjectThemeColor = msoThemeColorAccent5
.Color.TintAndShade = 0
.Color.Brightness = -0.25
.Transparency = 0
.Radius = 6
End With
End Sub
Sub StopShapeGlow()
Sheet1.Shapes("Picture 1").Glow.Radius = 0
End Sub
However - you probably also want to bring the Shape to the Front, so that the other Pictures don't cover up the outline. (You should be able to use "Record Macro" to get code for this)
You can trigger the change with something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value = "Cornwall" Then
MakeShapeGlow
Else
StopShapeGlow
End If
End Sub
(Obviously, a For Each loop that un-glows all shapes and then glows as shape based on name, such as "Pic_Cornwall" would be far more efficient than typing out new Subs and If chains for every county)
I'm Using Microsoft Excel 2013.
I have a lot of data that I need to separate in Excel that is in a single cell. The "Text to Columns" feature works great except for one snag.
In a single cell, I have First Name, Last Name & Email address. The last name and email addresses do not have a space between them, but the color of the names are different than the email.
Example (all caps represent colored names RGB (1, 91, 167), lowercase is the email which is just standard black text):
JOHN DOEjohndoe#acmerockets.com
So I need to put a space after DOE so that it reads:
JOHN DOE johndoe#acmerockets.com
I have about 20k rows to go through so any tips would be appreciated. I just need to get a space or something in between that last name and email so I can use the "Text to Columns" feature and split those up.
Not a complete answer, but I would do it way:
Step 1 to get rid of the formatting:
Copy all text that you have to the notepad
Then copy-paste text from Notepad to excel as text
I think this should remove all the formatting issues
Step 2 is to use VBA to grab emails. I assume that you have all your emails as lowercase. Therefore something like this should do the trick (link link2):
([a-z0-9\-_+]*#([a-z0-9\-_+].)?[a-z0-9\-_+].[a-z0-9]{2,6})
Step 3 is to exclude emails that you extracted from Step2 from your main text. Something like this via simple Excel function:
=TRIM(SUBSTITUTE(FULLTEXT,EMAIL,""))
Since you removed all the formatting in Step1, you can apply it back when you done
You can knock this out pretty quickly taking advantage of a how Font returns the Color for a set of characters that do not have the same color: it returns Null! Knowing this, you can iterate through the characters 2 at a time and find the first spot where it throws Null. You now know that the color shift is there and can spit out the pieces using Mid.
Code makes use of this behavior and IsNull to iterate through a fixed Range. Define the Range however you want to get the cells. By default it spits them out in the neighboring two columns with Offset.
Sub FindChangeInColor()
Dim rng_cell As Range
Dim i As Integer
For Each rng_cell In Range("B2:B4")
For i = 1 To Len(rng_cell.Text) - 1
If IsNull(rng_cell.Characters(i, 2).Font.Color) Then
rng_cell.Offset(0, 1) = Mid(rng_cell, 1, i)
rng_cell.Offset(0, 2) = Mid(rng_cell, i + 1)
End If
Next
Next
End Sub
Picture of ranges and results
The nice thing about this approach is that the actual colors involved don't matter. You also don't have to manually search for a switch, although that would have been the next step.
Also your neighboring cells will be blank if no color change was found, so it's decently robust against bad inputs.
Edit adds ability to change original string if you want that instead:
Sub FindChangeInColorAndAddChar()
Dim rng_cell As Range
Dim i As Integer
For Each rng_cell In Range("B2:B4")
For i = 1 To Len(rng_cell.Text) - 1
If IsNull(rng_cell.Characters(i, 2).Font.Color) Then
rng_cell = Mid(rng_cell, 1, i) & "|" & Mid(rng_cell, i + 1)
End If
Next
Next
End Sub
Picture of results again use same input as above.
I have troubles to read out the font information of an Excel cell containing text of mixed color with Matlab using ActiveX.
Take as an example an excel file with the string "GreenBlueRedBlack" in cell A1 with respective parts of the string in stated color.
MyExcel = actxserver('Excel.Application');
Workbook = MyExcel.Workbooks.Open('D:\data\Test.xlsx');
MySheet = MyExcel.ActiveWorkBook.Sheets.Item(1);
Text=get(MySheet.Range('A1').Characters,'Text');
Color=MySheet.Range('A1').Characters.Font.Color; % provides NaN
for m=1:size(Text,2) % read out letters seperately
Color(m)=MySheet.Range('A1').Characters(m,1).Font.Color;
end
The code of course provides NaN when indexing to the whole cell.
I am unable to find a way to correctly subindex and loop through each letter in the cell.
If I understood correctly Characters(x,y) should be fed with startpoint and length of the wanted subpart of the cell. But Characters(1,1) only returns NaN and Characters(2,1) as well as Characters(1,2) exceeds the matrix dimensions.
How does subindexing to a substring of a cell work?
Thank you.
I found a workaround, maybe somebody can benefit from it.
Add following Code into the Module1 of the Excel file.
Public Function getCellInfo(Row As Variant, Col As Variant, Sheet As Variant)
ActiveWorkbook.Sheets(Sheet).Activate
Text = Cells(Col)(Row).Text
TextLength = Len(Cells(Col)(Row))
Dim Color() As Variant
ReDim Color(TextLength)
For m = 0 To TextLength - 1
Color(m) = Cells(Col)(Row).Characters(m + 1, 1).Font.Color
Next
getCellInfo = Color
End Function
Then call the macro from Matlab using:
ColorVector=MyExcel.Run('getCellInfo',Sheet,Row,Col);
It's not very pretty though. If somebody knows a more elegant way without calling an excel macro that would be awesome.
Maybe too late, but this is the solution :
color = MySheet.Range('A1').get('Characters', start, length).Font.Color;
I create a pie chart in Excel 2013 using VBA. Everything works like expected: The chart is painted and each segment of that chart has its percentage value attached to it.
Now I have the problem that I got a lot of parts that are below 1% of the data making that chart very ugly with all that "0%" parts and its labels.
Now I still want all pies (otherwise I would just have filtered the source data) but I do only want lables on segments that are at least 2% of the data.
Is that possible?
Set DataSource = CreatePivotTableCurrFy
If Not (DataSource Is Nothing) Then
' Create chart object
Call ThisWorkbook.Worksheets("META").Shapes.AddChart(xlPie, 600, 200, 504, 360)
Set Co = ThisWorkbook.Worksheets("META").ChartObjects(2)
Co.chart.SetSourceData Source:=DataSource
Co.chart.ChartTitle.Text = "Sales by Brand"
Co.chart.SeriesCollection(1).ApplyDataLabels ShowPercentage:=True, ShowValue:=False
End If
You can try this not really very neat solution.
Dim d As Datalabel, Dim v As Long
For Each d In Co.chart.SeriesCollection(1).DataLabels
'v = CLng(Mid(d.Caption, 1, Len(d.Caption) - 1))
v = CLng(Split(d.Caption, "%")(0)) '~~> just thought this is better
If v < 2 Then d.Delete
Next
it is possible, just a bit complicated :) I take you want to hide the portion under 2% and you need to it for the slice as well as the legend and so on.
Naturally you start by selecting the slices of the pie that doesn't reach 2% (that is quite easy and it depends on how you give that % to your slices).
Then you can look here for a full procedure to follow. This link shows some code to do what I explained.
We are generating long Excel sheets using various tools, which have to be reviewed and used as input further down in the workflow.
The problem that some cells are too small for texts they contain.
So humans and programs that are reading the worksheets will not see the same data.
This is usually true for merged cells containing auto-wrapped texts, when Excel does not adjust the row height properly. But there are also other cases: for instance, when some columns have width explicitly set, which is not enough for long values.
|Group|Def1 |Subgroup|Definition| Id |Data |Comment |
|-------------------------------------------------------|
| G1 | | G1-1 |Important |G1-1-1|... | |
| |Long | |about G1-1|G1-1-2|.....|........ |
| |text |-------------------------------------------|
| |about| G1-2 |Another |G1-2-1|... | |
| |group| |important |G1-2-2|... |long comme|
| |G1. | |text about|G1-2-3| | |
|-------------------------------------------------------|
Here, some cells in "Definition" and "Comment" are not fully visible.
Is there any method to find such cells programmatically?
To detect these cells (I'm not talking about fixing the problem), you could use the Text method of a Range object.
For example, Range("A1").Value might be 123456789, but if it's formatted as Number and the column is not wide enough, Range("A1").Text will be "###" (or however many # signs fit in the cell).
Here's a trick I've used before:
With Columns("B:B")
oldWidth = .ColumnWidth ' Save original width
.EntireColumn.AutoFit
fitWidth = .ColumnWidth ' Get width required to fit entire text
.ColumnWidth = oldWidth ' Restore original width
If oldWidth < fitWidth Then
' Text is too wide for column.
' Do stuff.
End If
End With
Of course this will apply to an entire column at a time. You can still use this by copying cells over one by one to a dummy column and do the AutoFit test there.
But probably more useful to you is an earlier answer of mine to this question: Split text across multiple rows according to column width. It describes a method to determine the width of the text in any given cell (and compare it to the cell's actual width to determine whether the text fits or not).
EDIT Responding to your comment: If some of your cells are tall enough to show 2 or more lines of text, then you can use a similar approach as described in my previous answer, first using .EntireRow.AutoFit to determine the height of the font and .RowHeight to determine how many lines fit in the cell, then figuring out whether the text can fit in that number of lines in a cell of that width, using the method of the previous question.
Unmerge all cells in the workbook and use
Thisworkbook.sheets("Name").rows(index).entirerow.autofit
And the same for columns.
What's the use of keeping the merged cells anyway except for esthetic reasons?
Only the value of the "base cell" is taken into account (upper left).
I bumped into the same problem today. I am trying this trick to dodge it. Perhaps, it might be useful for you. It is coded to deal with one column width merging areas:
'Sheet2 is just merely support tool no data sheet in ThisWorkbook
With Sheet2.Range(target.Address)
target.Copy
.PasteSpecial xlPasteAll
.UnMerge
If .MergeArea.Count > 1 Then .UnMerge
.ColumnWidth = target.ColumnWidth
.Value = target.Value
.EntireRow.AutoFit
target.MergeArea.EntireRow.RowHeight = _
1.05 * .RowHeight / target.MergeArea.Rows.Count
.ClearContents
.ClearFormats
End With
Unfortunately, if there are several columns with merged cells like this, perhaps their mutual needed height will collide with each other and extra code will be needed for restoring harmony. Looks like an interesting piece of code.
Wish you find this helpful.