I have a code for inserting an attached file to a certain column and resizing it so that it perfectly fills the cell. Only problem I have now is that the object is just a blank rectangle and hard to spot if there is even anything in the cell.
I've tried IconLabel:=Range("A" & ActiveCell.Row) so that it shows the ID # of the row but it seems to show it very stretched out and to the point where you can't see anything.
Sub Macro1()
Range("X" & ActiveCell.Row).Select
Dim vFile As Variant, Sh As Object
vFile = Application.GetOpenFilename("All Files,*.*", Title:="Find file to insert")
If vFile = False Then Exit Sub
Dim OleObj As OLEObject
Set OleObj = ActiveSheet.OLEObjects.Add(Filename:=vFile, Link:=False, DisplayAsIcon:=True, IconFileName:= _
"C:\WINDOWS\Installer\{90110409-6000-11D3-8CFE-0150048383C9}\xlicons.exe", _
IconIndex:=0, IconLabel:=Range("A" & ActiveCell.Row).Value)
OleObj.ShapeRange.LockAspectRatio = msoFalse
OleObj.Height = Range("X" & ActiveCell.Row).Height
OleObj.Width = Range("X" & ActiveCell.Row).Width
End Sub
This would make the cell red, because of the vbRed, furthermore, it would be about 4 times less than the standard cell:
With OleObj
.ShapeRange.LockAspectRatio = msoFalse
.Height = Range("X" & ActiveCell.Row).Height / 2
.Width = Range("X" & ActiveCell.Row).Width / 2
.Interior.Color = vbRed
End With
Thus, it would be different and visible. These are the other built-in colors, from the VBA library (Press F2):
Related
Is there any way to align Center Header in Excel? I know there is no any built in solution but is there any VBA code that would work. I have been trying copying cells to header, setting center header with VBA but my Center Header is "Align Center" all the time.
I have even found very complex code to calculate length of sentences and add spaces to each row but it doesn't really work correctly.
I can also set rows to repeat on top and forget about header but what about footer then? How I can set Center Footer to align my two row text to align left?
I have tried:
With ActiveSheet.PageSetup
.LeftHeader = Range("a1").Value & " " & Range("b1").Value & " " & Range("a2").Value & " " & Range("b2").Value
End With
Also sending named range to header:
Option Explicit
Sub SetCenterHeader()
Dim txt As String
Dim myRow As Range
With Range("NorthHead") ' reference named range
For Each myRow In .Rows ' loop through referenced range rows
txt = txt & Join(Application.Transpose(Application.Transpose(myRow.Value)), " ") & vbLf ' update 'txt' with current row cells values joined and separated by a blank
Next
End With
ActiveSheet.PageSetup.CenterHeader = Left(txt, Len(txt) - 1) ' set CenterHeader with resulting 'txt' excluding last vblf character
ActiveWindow.SelectedSheets.PrintOut Copies:=1
End Sub
Result is always the same:
May try the following workaround and modify to your requirements
Sub test2()
Dim CenHd1 As String, CenHd2 As String, Fname As String
Dim Rng As Range
Dim Sht As Worksheet, MnSht As Worksheet
Dim Cht As ChartObject
Set Sht = ThisWorkbook.Worksheets(3)
Set MnSht = ThisWorkbook.Worksheets(1)
Set Rng = Sht.Range("F1:F2")
CenHd1 = "Excel"
CenHd2 = "I am already left Aligned"
Sht.Range("F1").Value = CenHd1
Sht.Range("F2").Value = CenHd2
Sht.Activate
ActiveWindow.DisplayGridlines = False
With Rng
.Columns.AutoFit 'added after taking trial snapshot to perfectly center and left align
.HorizontalAlignment = xlLeft
.Font.Name = "Bookman Old Style"
.Font.Size = 12
'May specify other visual effects
End With
Rng.CopyPicture xlScreen, xlPicture
Set Cht = Sht.ChartObjects.Add(0, 0, Rng.Width * 1.01, Rng.Height * 1.01)
Cht.Name = "TmpChart"
Sht.Shapes("TmpChart").Line.Visible = msoFalse
Cht.Chart.Paste
Fname = "C:\Users\user\Desktop\CentHead " & Format(Now, "dd-mm-yy hh-mm-ss") & ".jpg"
Cht.Chart.Export Filename:=Fname, Filtername:="JPG"
DoEvents
Cht.Delete
ActiveWindow.DisplayGridlines = True
MnSht.Activate
With MnSht.PageSetup.CenterHeaderPicture
.Filename = Fname
'.Height = 275.25
'.Width = 463.5
'.Brightness = 0.36
'.ColorType = msoPictureGrayscale
'.Contrast = 0.39
'.CropBottom = 0
'.CropLeft = 0
'.CropRight = 0
'.CropTop = 0
End With
'Enable the image to show up in the center header.
MnSht.PageSetup.CenterHeader = "&G"
'for Trial only
ActiveWindow.View = xlPageLayoutView
' Clear junk files
If Dir(Fname) <> "" Then Kill (Fname)
End Sub
Tried as follows
the code could also be modified as a function / procedure with parameters for repeated use with different Sheets, Workbooks etc. Hope it will help to serve the purpose.
I have managed to pull together some VBA code from other sources (many thanks) to create something that is about 80% complete. However when I send or open my spreadsheet on another computer my pictures do not appear (just a red X).
My research has lead me to use and insert the
ActiveSheet.Shapes.AddPicture method however I am unsure how to build this into my functioning code / where to place this. I have filenames in Column D which relate to the stored pictures from my folder. The pictures are loaded into Column C and this allworks perfectly, I have approx 550 jpeg files. However I cannot view the images once it's off my computer
My working code is:
Sub InsertPicsr1Reg()
Dim fPath As String, fName As String
Dim r As Range
Dim shp As Shape
Application.ScreenUpdating = False
fPath = "\Desktop\test workings\"
For Each r In Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)
On Error GoTo errHandler
If r.Value <> "" Then
With ActiveSheet.Pictures.Insert(fPath & r.Value)
.ShapeRange.LockAspectRatio = msoTrue
.Top = Cells(r.Row, 3).Top
.Left = Cells(r.Row, 3).Left
If .ShapeRange.Width > Columns(3).Width Then .ShapeRange _
.Width = Columns(3).Width
Rows(r.Row).RowHeight = .ShapeRange.Height
End With
End If
errHandler:
If Err.Number <> 0 Then
Debug.Print Err.Number & ", " & Err.Description & ", " & r.Value
On Error GoTo -1
End If
Next r
For Each shp In ActiveSheet.Shapes
shp.Placement = xlMoveAndSize
Next shp
Application.ScreenUpdating = True
End Sub
try this:
Sub InsertPicsr1Reg()
Dim fPath As String, fName As String
Dim r As Range
Dim shp As Shape
Application.ScreenUpdating = False
fPath = "\Desktop\test workings\"
For Each r In Range("D2:D" & Cells(Rows.Count, 4).End(xlUp).Row)
If r.Value <> "" Then
With ActiveSheet
.Shapes.AddPicture fPath & r.Value, _
msoFalse, msoTrue, _
.Cells(r.Row, 3).Left, _
.Cells(r.Row, 3).Top, _
.Columns(3).Width, _
.Rows(r.Row).Height
End With
end if
next
end sub
I have a subroutine working just fine to export an image taken from a range in excel, but I´m facing a problem... Even when I managed to make the chart object transparent and without a border... the exported image has a lot of unused area that I wish to crop before exporting it.
Sub BtnSaveFile_Click()
Dim RgExp As Range
Dim ImageToExport As Excel.ChartObject
Const sSlash$ = "/"
Const sPicType$ = ".png"
Dim sChartName$
Dim sPath$
Dim sBook$
Set RgExp = Range("G4:N28")
RgExp.CopyPicture xlScreen, xlPicture
Set ImageToExport = ActiveSheet.ChartObjects.Add(Left:=RgExp.Left - 80, Top:=RgExp.Top - 80, Width:=RgExp.Width - 80, Height:=RgExp.Height - 80)
With ImageToExport.Chart.ChartArea.Format.Fill
.Visible = msoFalse
End With
With ImageToExport.Chart.ChartArea.Format.Line
.Visible = msoCFalse
End With
ImageToExport.Chart.Paste
Start:
sChartName = Application.InputBox("Enter A Name Of Your Choice" & vbCr & _
"There Is No Default Name Available" & vbCr & _
"The File Will Be Saved At C:\SECTIONIZER\SAVED SECTION\", "PROVIDE A NAME FOR THE VIEW", "")
If sChartName = Empty Then
MsgBox "Please Enter A File Name", , "Invalid Entry"
GoTo Start
End If
If sChartName = "False" Then
ImageToExport.Delete
Exit Sub
End If
sBook = "C:\SECTIONIZER\SAVED SECTION"
sPath = sBook & sSlash & sChartName & sPicType
ImageToExport.Chart.Export Filename:=sPath, FilterName:="PNG"
ImageToExport.Delete
ExitProc:
Application.ScreenUpdating = True
Set ImageToExport = Nothing
Set RgExp = Nothing
End Sub
I had the idea to crop it by seeking the first black pixel at each side of the image (left,top,right,bottom), so I can then set the coordinates to crop out the empty pixels, but I haven´t found a code to do so.
EDIT: added images from OP's supplied links
From this:
To this:
You will need to start the macro recorder and then crop the picture to the area of your liking, and then you can use the coordinates recorded in your subroutine. The following is a sample of what you will get
Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 196
Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 196
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 0
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = -8
I managed to solve it. First of all, I grouped all the shapes at the excel range, with the group selected, established W and H of the selection to later attribute it to the Width and Height of the Chart to be added, then on the added chart Pasted the Copied Selection... Here is the final outcome:
Sub BtnSaveFile_Click()
Dim ImageToExport As Excel.ChartObject
Dim Shp As Shape
Dim RangeToTest As Range
Dim CC As Range
Dim DD As Range
Const sSlash$ = "/"
Const sPicType$ = ".png"
Dim sChartName$
Dim sPath$
Dim sBook$
'The images at the range are selected and grouped
Set RangeToTest = Range("G4:N28")
For Each CC In RangeToTest
Set ShpList = Sheets("SECTIONIZER").Shapes
For Each Shp In ShpList
If CC.Address = Shp.TopLeftCell.Address Then
Shp.Select Replace:=False
End If
Next Shp
Next CC
Selection.ShapeRange.Group.Select
'W and H are established with the above selected group Width and Height
W = Selection.Width
H = Selection.Height
'Selected group is copied as picture
Selection.CopyPicture xlScreen, xlPicture
'Chart Object is Added with the W and H values
Set ImageToExport = ActiveSheet.ChartObjects.Add(0, 0, W , H)
With ImageToExport.Chart.ChartArea.Format.Fill
.Visible = msoFalse
End With
With ImageToExport.Chart.ChartArea.Format.Line
.Visible = msoCFalse
End With
'Group Selected is then Pasted into the above added Chart
ImageToExport.Chart.Paste
Start:
' Pop Up Window For User To Enter File Name
sChartName = Application.InputBox("Enter A Name Of Your Choice" & vbCr & _
"There Is No Default Name Available" & vbCr & _
"The File Will Be Saved At C:\SECTIONIZER\SAVED SECTION\", "PROVIDE A NAME FOR THE VIEW", "")
' User presses "OK" without entering a name
If sChartName = Empty Then
MsgBox "Please Enter A File Name", , "Invalid Entry"
GoTo Start
End If
' If Cancel Button Is Pressed
If sChartName = "False" Then
ImageToExport.Delete
Exit Sub
End If
' If A Name Was Given, View Is Exported As A *.PNG Image
' At C:\SECTIONIZER\SAVED SECTION
sBook = "C:\SECTIONIZER\SAVED SECTION"
sPath = sBook & sSlash & sChartName & sPicType
ImageToExport.Chart.Export Filename:=sPath, FilterName:="PNG"
ImageToExport.Delete
ExitProc:
Application.ScreenUpdating = True
Set ImageToExport = Nothing
Set RgExp = Nothing
End Sub
Edit:
After doing a bit more research I stumbled on this handy little shortcut:
Just right click on the little arrows on the bottom left corner to show all sheets - no code required!
I have an excel workbook with 100 tabs. Luckily for me the tabs are all numbered 1-100. I Have an index page with all the numbers in a row and I would like to make a row next to that row with a hyperlink to the numbered tab.
A B
---------------------------
| 1 | link to tab 1 |
---------------------------
| 2 | link to tab 2 |
---------------------------
etc...
So far the most promising thing I've found is:
=Hyperlink(“C:\Documents and Settings\Admin1\Desktop\” & A1 & “.xls”,A1)
I know that the hyperlink function expects:
=HYPERLINK(link_location,friendly_name)
And when I do it manually, I get this:
=HYPERLINK('1'!$A$1,A1)
So I want to do something like this:
=HYPERLINK('& A1 &'!$A$1,A1)
But it's not working. Any help is much appreciated. Also, if there is an easier way to approach this - I am all ears.
With code something like this
Press Alt + F11 to open the Visual Basic Editor (VBE).
From the Menu, choose Insert-Module.
Paste the code into the right-hand code window.
Close the VBE, save the file if desired.
In excel-2003 go to Tools-Macro-Macros and double-click CreateTOC
In excel-2007 click the Macros button in the Code group of the Developer tab, then click CreateTOC in the list box.
Option Explicit
Sub CreateTOC()
Dim ws As Worksheet
Dim nmToc As Name
Dim rng1 As Range
Dim lngProceed As Boolean
Dim bNonWkSht As Boolean
Dim lngSht As Long
Dim lngShtNum As Long
Dim strWScode As String
Dim vbCodeMod
'Test for an ActiveWorkbook to summarise
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
'Turn off updates, alerts and events
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
'If the Table of Contents exists (using a marker range name "TOC_Index") prompt the user whether to proceed
On Error Resume Next
Set nmToc = ActiveWorkbook.Names("TOC_Index")
If Not nmToc Is Nothing Then
lngProceed = MsgBox("Index exists!" & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbCritical, "Warning")
If lngProceed = vbYes Then
Exit Sub
Else
ActiveWorkbook.Sheets(Range("TOC_Index").Parent.Name).Delete
End If
End If
Set ws = ActiveWorkbook.Sheets.Add
ws.Move before:=Sheets(1)
'Add the marker range name
ActiveWorkbook.Names.Add "TOC_INDEX", ws.[a1]
ws.Name = "TOC_Index"
On Error GoTo 0
On Error GoTo ErrHandler
For lngSht = 2 To ActiveWorkbook.Sheets.Count
'set to start at A6 of TOC sheet
'Test sheets to determine whether they are normal worksheets
ws.Cells(lngSht + 4, 2).Value = TypeName(ActiveWorkbook.Sheets(lngSht))
If TypeName(ActiveWorkbook.Sheets(lngSht)) = "Worksheet" Then
'Add hyperlinks to normal worksheets
ws.Hyperlinks.Add Anchor:=ws.Cells(lngSht + 4, 1), Address:="", SubAddress:="'" & ActiveWorkbook.Sheets(lngSht).Name & "'!A1", TextToDisplay:=ActiveWorkbook.Sheets(lngSht).Name
Else
'Add name of any non-worksheets
ws.Cells(lngSht + 4, 1).Value = ActiveWorkbook.Sheets(lngSht).Name
'Colour these sheets yellow
ws.Cells(lngSht + 4, 1).Interior.Color = vbYellow
ws.Cells(lngSht + 4, 2).Font.Italic = True
bNonWkSht = True
End If
Next lngSht
'Add headers and formatting
With ws
With .[a1:a4]
.Value = Application.Transpose(Array(ActiveWorkbook.Name, "", Format(Now(), "dd-mmm-yy hh:mm"), ActiveWorkbook.Sheets.Count - 1 & " sheets"))
.Font.Size = 14
.Cells(1).Font.Bold = True
End With
With .[a6].Resize(lngSht - 1, 1)
.Font.Bold = True
.Font.ColorIndex = 41
.Resize(1, 2).EntireColumn.HorizontalAlignment = xlLeft
.Columns("A:B").EntireColumn.AutoFit
End With
End With
'Add warnings and macro code if there are non WorkSheet types present
If bNonWkSht Then
With ws.[A5]
.Value = "This workbook contains at least one Chart or Dialog Sheet. These sheets will only be activated if macros are enabled (NB: Please doubleclick yellow sheet names to select them)"
.Font.ColorIndex = 3
.Font.Italic = True
End With
strWScode = "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & vbCrLf _
& " Dim rng1 As Range" & vbCrLf _
& " Set rng1 = Intersect(Target, Range([a6], Cells(Rows.Count, 1).End(xlUp)))" & vbCrLf _
& " If rng1 Is Nothing Then Exit Sub" & vbCrLf _
& " On Error Resume Next" & vbCrLf _
& " If Target.Cells(1).Offset(0, 1) <> ""Worksheet"" Then Sheets(Target.Value).Activate" & vbCrLf _
& " If Err.Number <> 0 Then MsgBox ""Could not select sheet"" & Target.Value" & vbCrLf _
& "End Sub" & vbCrLf
Set vbCodeMod = ActiveWorkbook.VBProject.VBComponents(ws.CodeName)
vbCodeMod.CodeModule.AddFromString strWScode
End If
'tidy up Application settins
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
ErrHandler:
If Err.Number <> 0 Then MsgBox Err.Description & vbCrLf & "Please note that your Application settings have been reset", vbCritical, "Code Error!"
End Sub
My snippet:
Sub AddLinks()
Dim wksLinks As Worksheet
Dim wks As Worksheet
Dim row As Integer
Set wksLinks = Worksheets("Links")
wksLinks.UsedRange.Delete
row = 1
For Each wks In Worksheets
' Debug.Print wks.Name
wks.Hyperlinks.Add wksLinks.Cells(row, 1), "", wks.Name & "!A1", , wks.Name
row = row + 1
Next wks
End Sub
Assumes a worksheet named 'Links"
Might not be a direct answer to your method, but I would create something more pleasing to the eye, like ... some shapes formatted nicely and then asign some basic macros to them, for selecting the sheets.
This can be easely modified to go to a specific address (like the Go TO Ctrl+Gbuilt in Excel feature).Hope this helps on the fashion style of your file :)
EDIT!
Don't know why my answer received a -1 rating. As I've said it's an alternative and not a direct solution to the given question. Still, I do believe my initial answer was superficial without a proven/working VBA code, thus I've developed a little practical example below:
Sub Add_Link_Buttons()
'Clear any Shapes present in the "Links" sheet
For j = ActiveSheet.Shapes().Count To 1 Step -1
ActiveSheet.Shapes(j).Delete
Next j
'Add the shapes and then asign the "Link" Macros
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveSheet.Shapes.AddShape Type:=msoShapeRoundedRectangle, Left:=50, Top:=i * 25, Width:=100, Height:=25
ActiveSheet.Shapes(i).OnAction = "Select_Sheet" & i
'even add the the sheet Name as Test:
ActiveSheet.Shapes(i).TextFrame2.TextRange.Characters.Text = Sheets(i).Name
Next i
End Sub
where the "basic Select Macros" whould be:
Sub Select_Sheet1()
ActiveWorkbook.Sheets(1).Select
End Sub
Sub Select_Sheet2()
ActiveWorkbook.Sheets(2).Select
End Sub
Sub Select_Sheet3()
ActiveWorkbook.Sheets(3).Select
End Sub
' and so on!
' Note! to link a specific address within the sheets use the range like in 'Sheets(1).Range("A1").Select
Again, This is an alternative and doesn't add hyperlinks (as asked), but enables the sheet select from the same location.
TO address the buttons to links for outside files, simply define the address > filename/workbook Sheets() and Open ;)
Here is the code I use:
Sub CreateIndex()
'This macro checks for an Index tab in the active worksheet and creates one if one does not already exist.
'If an Index tab already exists, the user is asked to continue. If they continue, the original Index tab is replaced by a new Index tab. If they do not continue, the macro stops.
'The user is then asked if they want to create a link back to the Index tab on all other worksheets (yes or no) and the macro acts accordingly.
Dim wsIndex As Worksheet
Dim wSheet As Worksheet
Dim retV As Integer
Dim i As Integer
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set wsIndex = Worksheets.Add(Before:=Sheets(1))
With wsIndex
On Error Resume Next
.Name = "Index"
If Err.Number = 1004 Then
If MsgBox(Prompt:="A sheet named ""Index"" already exists. Do you wish to continue by replacing it with a new Index?", _
Buttons:=vbInformation + vbYesNo) = vbNo Then
.Delete
MsgBox "No changes were made."
GoTo EarlyExit:
End If
Sheets("Index").Delete
.Name = "Index"
End If
On Error GoTo 0
retV = MsgBox("Create links back to ""Index"" sheet on other sheets?", vbYesNo, "Linking Options")
For Each wSheet In ActiveWorkbook.Worksheets
If wSheet.Name <> "Index" Then
i = i + 1
If wSheet.Visible = xlSheetVisible Then
.Range("B" & i).Value = "Visible"
ElseIf wSheet.Visible = xlSheetHidden Then
.Range("B" & i).Value = "Hidden"
Else
.Range("B" & i).Value = "Very Hidden"
End If
.Hyperlinks.Add Anchor:=.Range("A" & i), Address:="", SubAddress:="'" & wSheet.Name & "'!A1", TextToDisplay:=wSheet.Name
If retV = 6 And wSheet.Range("A1").Value <> "Index" Then
wSheet.Rows(1).Insert
wSheet.Range("A1").Hyperlinks.Add Anchor:=wSheet.Range("A1"), Address:="", SubAddress:="'" & .Name & "'!A1", TextToDisplay:=.Name
End If
End If
Next wSheet
.Rows(1).Insert
With .Rows(1).Font
.Bold = True
.Underline = xlUnderlineStyleSingle
End With
.Range("A1") = "Sheet Name"
.Range("B1") = "Status"
.UsedRange.AutoFilter
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Application.Goto Reference:="R1C1"
.Columns("A:B").AutoFit
End With
With ActiveWorkbook.Sheets("Index").Tab
.Color = 255
.TintAndShade = 0
End With
EarlyExit:
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
-Mike
I am trying to copy data from excel file to a word file as a screenshot. But the issue is that the data pasted is very small. Is there any way to increase its size while copying or after pasting? Below is the code i have written. Thanks in advance.
Range("A" & startRow & ":G" & endRow).Select
Selection.Copy
With WordApp
.Selection.PasteSpecial Link:=False, DisplayAsIcon:=False, _
DataType:=wdPasteMetafilePicture, Placement:=wdInLine
.Selection.TypeParagraph
.Selection.Orientation = wdTextOrientationVertical
End With
You can resize your shape after you've copied it as it is the last shape you built.
Here is the code you can add:
Dim oShape As Word.InlineShape
Dim i As Integer
i = ActiveDocument.InlineShapes.Count
' set oShape to the LAST inlineshape
Set oShape = ActiveDocument.InlineShapes(i)
With oShape
' examples only - scale to 90%
.ScaleHeight = 90
.ScaleWidth = 90
' * * * etc etc etc * * * *
End With
Set oShape = Nothing
And you can simplify your Excel code because you don't have to select before copying:
Range("A" & startRow & ":G" & endRow).Copy
is enough