I've written this code but the code fails to remove the chart titles when it is run. If I run the code manually using the step-in function it works perfectly.
I've tried using Application.Wait before the newChart.HasTitle = False line but it doesn't seem to work either. Any ideas?
Sub InsertPieCharts()
Dim xl As Excel.Application
Dim aTB As Table
Dim aSL As Slide
Dim sh As Shape
Dim newChart As Chart
Dim aTX As Shape
Dim chartAreasWidth As Double, chartAreasHeight As Double, firstLeft As Double, chartsHSpace As Double, chartsLeft As Double, chartsTop As Double, firstTop As Double, chartsVSpace As Double, tHeight As Double, tWidth As Double, cWidth As Double, cHeight As Double
Dim r As Integer, c As Integer
'Measures
chartAreasWidth = 25 'cm
chartAreasHeight = 4.4 'cm
firstLeft = 3.13 'cm
firstTop = 13.01 'cm
tHeight = 1 'cm
tWidth = 1 'cm
cWidth = 2.5 'cm
cHeight = 2.2 'cm
'Objects
Set xl = CreateObject("Excel.Application")
Set aSL = ActivePresentation.Slides(16)
For Each sh In aSL.Shapes
If sh.HasTable Then
If sh.Table.Cell(1, 1).Shape.TextFrame2.TextRange = "Datatable" Then
Set aTB = sh.Table
Exit For
End If
End If
Next sh
chartsHSpace = xl.CentimetersToPoints(chartAreasWidth / (aTB.Columns.Count - 1))
chartsVSpace = xl.CentimetersToPoints(chartAreasHeight / (aTB.Rows.Count - 2))
chartsLeft = xl.CentimetersToPoints(firstLeft)
chartsTop = xl.CentimetersToPoints(firstTop)
tHeight = xl.CentimetersToPoints(tHeight)
tWidth = xl.CentimetersToPoints(tWidth)
cHeight = xl.CentimetersToPoints(cHeight)
cWidth = xl.CentimetersToPoints(cWidth)
For r = 3 To aTB.Rows.Count
For c = 2 To aTB.Columns.Count
Set newChart = aSL.Shapes.AddChart2(-1, xlPie, chartsLeft - (cWidth - tWidth) / 2 + cWidth * (c - 2), chartsTop - (cHeight - tHeight) / 2 + cHeight * (r - 3), cWidth, cHeight).Chart
With newChart.ChartData.Workbook.Sheets(1)
.Cells(1, 2).Value = ""
.Cells(2, 1).Value = "Fill"
.Cells(2, 2).Value = aTB.Cell(r, c).Shape.TextFrame2.TextRange * 1
.Cells(3, 2).Value = 100 - aTB.Cell(r, c).Shape.TextFrame2.TextRange
.Cells(3, 1).Value = "Unfill"
.Rows(4).Delete
.Rows(4).Delete
End With
newChart.ChartData.Workbook.Close
If newChart.HasTitle = True Then
newChart.HasTitle = False
End If
If newChart.HasLegend = True Then
newChart.HasLegend = False
End If
newChart.SeriesCollection(1).Points(1).Format.Fill.ForeColor.RGB = RGB(176, 176, 176)
newChart.SeriesCollection(1).Points(2).Format.Fill.Visible = False
Set aTX = aSL.Shapes.AddTextbox(msoTextOrientationHorizontal, chartsLeft + chartsHSpace * (c - 2), chartsTop + chartsVSpace * (r - 3), tWidth, tHeight)
aTX.TextFrame2.TextRange = aTB.Cell(r, c).Shape.TextFrame2.TextRange
aTX.TextFrame2.HorizontalAnchor = msoAnchorCenter
aTX.TextFrame2.VerticalAnchor = msoAnchorMiddle
aTX.AutoShapeType = msoShapeOval
If aTB.Cell(r, c).Shape.TextFrame2.TextRange > 89.5 Then
aTX.TextFrame2.TextRange.Font.Size = 14
aTX.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
aTX.Fill.ForeColor.RGB = RGB(47, 105, 151)
ElseIf aTB.Cell(r, c).Shape.TextFrame2.TextRange > 79.5 Then
aTX.TextFrame2.TextRange.Font.Size = 14
aTX.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
aTX.Fill.ForeColor.RGB = RGB(169, 202, 228)
ElseIf aTB.Cell(r, c).Shape.TextFrame2.TextRange > 69.5 Then
aTX.TextFrame2.TextRange.Font.Size = 14
aTX.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
aTX.Fill.ForeColor.RGB = RGB(255, 170, 170)
ElseIf aTB.Cell(r, c).Shape.TextFrame2.TextRange >= 0 Then
aTX.TextFrame2.TextRange.Font.Size = 14
aTX.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
aTX.Fill.ForeColor.RGB = RGB(255, 0, 0)
End If
If aTB.Cell(r, c).Shape.TextFrame2.TextRange > 99.5 Then
aTX.TextFrame2.TextRange.Font.Size = 12
Else
aTX.TextFrame2.TextRange.Font.Size = 14
End If
aTX.Width = tWidth
aTX.Height = tHeight
Next c
Next r
End Sub
The solution to my own problem seems to first force the chart titles and then removing them like this
newChart.HasTitle = True
newChart.HasTitle = False
instead of
If newChart.HasTitle = True Then
newChart.HasTitle = False
End If
Related
Dim a As String
a = Cells(1, 4).Value
y1 = 240
y2 = 270
x1 = 5
hakahaka = Cells(47, 20).Value
For st = 1 To 12
charr = Mid(hakahaka, st, 1)
If charr = 1 Then
Set myDocument = ActiveSheet '000czarny 255bialy'
With myDocument.Shapes.AddLine(x1, y1, x1, y2).Line
.Weight = 1
grubosc = 1
x1 = x1 + grubosc
.ForeColor.RGB = RGB(0, 0, 0)
End With
Else
Set myDocument = ActiveSheet '000czarny 255bialy'
With myDocument.Shapes.AddLine(x1, y1, x1, y2).Line
.Weight = 1
grubosc = 1
x1 = x1 + grubosc
.ForeColor.RGB = RGB(255, 255, 255)
End With
End If
Next st
For i = 1 To Len(a)
char = Mid(a, i, 1)
char = Int(char)
For k = 26 To 40
o = Cells(k, 13).Value
If o = char Then
kreski = Cells(k, 16).Value
For licz = 1 To 12
smiecie = Mid(kreski, licz, 1)
If smiecie = 1 Then
Set myDocument = ActiveSheet '000czarny 255bialy'
With myDocument.Shapes.AddLine(x1, y1, x1, y2).Line
.Weight = 1
grubosc = 1
x1 = x1 + grubosc
.ForeColor.RGB = RGB(0, 0, 0)
End With
Else
Set myDocument = ActiveSheet '000czarny 255bialy'
With myDocument.Shapes.AddLine(x1, y1, x1, y2).Line
.Weight = 1
grubosc = 1
x1 = x1 + grubosc
.ForeColor.RGB = RGB(255, 255, 255)
End With
End If
Next licz
End If
Next k
Next i
If i > Len(a) Then
hakahaka = Cells(47, 20).Value
For ts = 1 To 12
charr = Mid(hakahaka, ts, 1)
If charr = 1 Then
Set myDocument = ActiveSheet '000czarny 255bialy'
With myDocument.Shapes.AddLine(x1, y1, x1, y2).Line
.Weight = 1
grubosc = 1
x1 = x1 + grubosc
.ForeColor.RGB = RGB(0, 0, 0)
End With
Else
Set myDocument = ActiveSheet '000czarny 255bialy'
With myDocument.Shapes.AddLine(x1, y1, x1, y2).Line
.Weight = 1
grubosc = 1
x1 = x1 + grubosc
.ForeColor.RGB = RGB(255, 255, 255)
End With
End If
Next ts
End If
End Sub
Here is my cod that should generate code 39. I saw that there is problem with line thickness(grubosc) when there is black line next to white they are not next to each other because there is very thin gap between them is that possible that black line is thicker than white line despite the fact that i set weight of both lines to be 2?
here is a rewrite of your code (untested)
Option Explicit
Const y1 = 240
Const y2 = 270
Const vbCzarny = vbBlack
Const vbBialy = vbWhite
Sub test()
Dim x1 As Integer
x1 = 5
Dim a As String
a = Cells(1, 4).Value
x1 = doHakahaka(Cells(47, 20).Value, x1)
Dim char2 As String
Dim k As Integer
Dim i As Integer
For i = 1 To Len(a)
char2 = Mid(a, i, 1)
For k = 26 To 40
If Int(char2) = Cells(k, 13).Value Then
x1 = doHakahaka(Cells(k, 16).Value, x1)
End If
Next k
Next i
If i > Len(a) Then
x1 = doHakahaka(Cells(47, 20).Value, x1)
End If
End Sub
Function doHakahaka(hakahaka As String, x1 As Integer)
Dim lineColor As Long
Dim charr As String
Dim st As Integer
Dim grubosc As Integer
grubosc = 1
For st = 1 To 12
charr = Mid(hakahaka, st, 1)
If charr = 1 Then
lineColor = vbCzarny
Else
lineColor = vbBialy
End If
With ActiveSheet.Shapes.AddLine(x1, y1, x1, y2).Line
.Weight = 1
.ForeColor.RGB = lineColor
End With
x1 = x1 + grubosc
Next st
doHakahaka = x1
End Function
Ok finally it works i forgot about adding blank spaces between characters,thanks jsotola for help:)
I want to control SAP from access to print a barcode label just by pressing a button in access.
Currently I have a script that only works if SAP is open
session.findById("wnd[0]/tbar[0]/okcd").Text ="pickLabel"
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]/usr/ctxtY_P_MAT").Text = "testbox"
session.findById("wnd[0]/usr/txtY_P_QUA").Text = "1"
session.findById("wnd[0]/usr/ctxtY_P_LGN").Text = "test"
session.findById("wnd[0]/usr/ctxtY_P_PRI").Text = "testPrinter"
session.findById("wnd[0]/usr/txtY_P_KSC").Text = "test"
session.findById("wnd[0]/usr/txtY_P_KSC").SetFocus
session.findById("wnd[0]/usr/txtY_P_KSC").caretPosition = 4
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]/tbar[1]/btn[8]").press
I would like to have a way to do it without having SAP open.
Also I need to record the barcode number, but in the screen this number is not shown.
Any idea?
Thanks!!!
I might have a solution for you.
I too needed SAP to print stickers on my Zebra Z4Mplus sticker printer.
What I did was use excel to generate my sticker and send them directly to the printer
First step was installing the printer, it is a TCP/IP printer that you have to connect directly to. The printer had a function to print all settings, I did that then used windows advanced printer setup, create a local TCP/IP port for the printer and added it. Google made this step easy.
Then in excel I inserted a chart on my worksheet.
then I created a shape and created the following code.
This code is an example, my code is much bigger, you need to generate all elements.
I used the GetPrinterFullNames function from pixcels.nl/set-activeprinter-excel/
For barcodes I used the following class stackoverflow.com/questions/13909248/generating-code-128-barcodes-using-excel-vba
You need to find the code128.fft file, I don't remember where I got it.
I also have a module for adding font to system without being administrator (using AddFontResource), storing font in excel worksheet
I got this module from this thread
http://www.mrexcel.com/forum/excel-questions/328457-how-do-you-embed-font-into-excel-file.html
So here is my code for printer my stickers.
Sub PrintExportControl()
Dim myprinter As String
Dim PrintersList() As String
Dim printer_name As String
Dim x As Long
GenerateExportControl
myprinter = Application.ActivePrinter
PrintersList() = GetPrinterFullNames
For x = 1 To UBound(PrintersList)
If InStr(1, PrintersList(x), "ExportControl", vbTextCompare) > 0 Then _
printer_name = PrintersList(x)
Next x
Application.ActivePrinter = printer_name
DoEvents
Sheet1.Shapes("chtExportControl").Chart.PrintOut , , , , "ExportControl"
Sheet1.Shapes("chtExportControl").Chart.PrintOut , , , , "ExportControl"
'Sheet1.Shapes("chtZSMI").Chart.PrintOut , , , , "ExportControl"
'Sheet1.Shapes("chtZSMI").Chart.PrintOut , , , , "ExportControl"
Application.ActivePrinter = myprinter
End Sub
And here is my code for generating the chart which has the sticker on it
Sub GenerateExportControl()
Dim mychart As Chart
Dim picLogo As Shape
Dim shpExportControl As Shape
Dim shpDate As Shape
Dim shpBadge As Shape
Dim shpPN As Shape
Dim shpSN As Shape
Dim shpESN As Shape
Dim shpPartDescription As Shape
Dim shpCSOrder As Shape
Dim shpSO As Shape
Dim shpCSOrderBarcode As Shape
Dim shpSOBarcode As Shape
Dim shp1stMil As Shape
Dim shpPUSML As Shape
Dim shpUSML As Shape
Dim shpITARCID As Shape
Dim shpPECCN As Shape
Dim shpECCN As Shape
Dim shpECL As Shape
' Get the TEMP path
Dim FSO As Object, TmpFolder As Object
Set FSO = CreateObject("scripting.filesystemobject")
Set TmpFolder = FSO.GetSpecialFolder(2)
' Focus a cell
ActiveSheet.Range("A92").Select
' Make sure the "Code 128" font is available
If FontIsInstalled("Code 128") = False Then
CreateFontFile
AddFont
End If
Dim BarcodeGenerator As clsBarcode
Set BarcodeGenerator = New clsBarcode
Set mychart = Sheet1.Shapes("chtExportControl").Chart
mychart.Parent.Width = 288
mychart.Parent.Height = 144
mychart.ChartArea.Border.LineStyle = xlNone
For Each MyShape In mychart.Shapes
MyShape.Delete
Next
Set picLogo = mychart.Shapes.AddPicture("C:\Users\pw46487\Desktop\archive\programs\pwc-faded.jpg", msoTrue, msoTrue, 0, 0, 100, 79.39)
picLogo.Left = mychart.Parent.Width / 2 - picLogo.Width / 2
picLogo.Top = mychart.Parent.Height / 2 - picLogo.Height / 2
Set shpExportControl = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 181, 17)
shpExportControl.TextFrame.Characters.Text = "EXPORT CLASSIFICATION"
shpExportControl.TextFrame.Characters.Font.Size = 18
shpExportControl.TextFrame.MarginLeft = 0
shpExportControl.TextFrame.MarginTop = 0
shpExportControl.TextFrame.MarginRight = 0
shpExportControl.TextFrame.MarginBottom = 0
shpExportControl.TextFrame.AutoSize = True
Set shpDate = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, 185, 0, 61, 11)
shpDate.TextFrame.Characters.Text = Day(Date) & "-" & MonthName(Month(Date), True) & "-" & Year(Date)
If IsDate(Worksheets("Sheet1").Range("B68")) Then _
shpDate.TextFrame.Characters.Text = Day(Worksheets("Sheet1").Range("B68")) & "-" & _
MonthName(Month(Worksheets("Sheet1").Range("B68")), True) & "-" & _
Year(Worksheets("Sheet1").Range("B68"))
shpDate.TextFrame.Characters.Font.Size = 12
shpDate.TextFrame.MarginLeft = 0
shpDate.TextFrame.MarginTop = 0
shpDate.TextFrame.MarginRight = 0
shpDate.TextFrame.MarginBottom = 0
shpDate.TextFrame.AutoSize = True
shpDate.Left = ((mychart.Parent.Width - shpDate.Width - shpExportControl.Width) / 2) + shpExportControl.Left + shpExportControl.Width
Set shpBadge = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, 185, 0, 100, 11)
shpBadge.TextFrame.Characters.Text = "Badge: " & Split(Worksheets("Sheet1").Range("B11"), " ")(0)
shpBadge.TextFrame.Characters.Font.Size = 12
shpBadge.TextFrame.MarginLeft = 0
shpBadge.TextFrame.MarginTop = 0
shpBadge.TextFrame.MarginRight = 0
shpBadge.TextFrame.MarginBottom = 0
shpBadge.TextFrame.AutoSize = True
shpBadge.Top = shpDate.Top + shpDate.Height + 2
shpBadge.Left = ((mychart.Parent.Width - shpBadge.Width - shpExportControl.Width) / 2) + shpExportControl.Left + shpExportControl.Width
Set shpPN = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, 185, 4.5, 100, 11)
shpPN.TextFrame.Characters.Text = "PN: " & Worksheets("Sheet1").Range("B1")
shpPN.TextFrame.Characters.Font.Size = 11
shpPN.TextFrame.MarginLeft = 0
shpPN.TextFrame.MarginTop = 0
shpPN.TextFrame.MarginRight = 0
shpPN.TextFrame.MarginBottom = 0
shpPN.TextFrame.AutoSize = True
shpPN.Top = shpBadge.Top + shpBadge.Height - 2
shpPN.Left = mychart.Parent.Width - shpPN.Width
If Worksheets("Sheet1").Range("B1") = "" Then shpPN.Visible = False
Set shpSN = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, 185, 4.5, 100, 11)
shpSN.TextFrame.Characters.Text = "SN: " & Worksheets("Sheet1").Range("B4")
shpSN.TextFrame.Characters.Font.Size = 11
shpSN.TextFrame.MarginLeft = 0
shpSN.TextFrame.MarginTop = 0
shpSN.TextFrame.MarginRight = 0
shpSN.TextFrame.MarginBottom = 0
shpSN.TextFrame.AutoSize = True
shpSN.Top = shpPN.Top + shpPN.Height - 2
shpSN.Left = mychart.Parent.Width - shpSN.Width
If Worksheets("Sheet1").Range("B4") = "" Then shpSN.Visible = False
Set shpESN = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, 185, 4.5, 100, 11)
shpESN.TextFrame.Characters.Text = "ESN: " & Worksheets("Sheet1").Range("B5")
shpESN.TextFrame.Characters.Font.Size = 11
shpESN.TextFrame.MarginLeft = 0
shpESN.TextFrame.MarginTop = 0
shpESN.TextFrame.MarginRight = 0
shpESN.TextFrame.MarginBottom = 0
shpESN.TextFrame.AutoSize = True
shpESN.Top = shpSN.Top + shpSN.Height - 2
shpESN.Left = mychart.Parent.Width - shpESN.Width
If Worksheets("Sheet1").Range("B5") = "" Then shpESN.Visible = msoFalse
Set shpPartDescription = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, 185, 4.5, 100, 11)
shpPartDescription.TextFrame.Characters.Text = Worksheets("Sheet1").Range("B50")
shpPartDescription.TextFrame.Characters.Font.Size = 11
shpPartDescription.TextFrame.MarginLeft = 0
shpPartDescription.TextFrame.MarginTop = 0
shpPartDescription.TextFrame.MarginRight = 0
shpPartDescription.TextFrame.MarginBottom = 0
shpPartDescription.TextFrame.AutoSize = True
shpPartDescription.Top = mychart.Parent.Height - shpPartDescription.Height
shpPartDescription.Left = mychart.Parent.Width - shpPartDescription.Width
Set shpCSOrder = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, 185, 4.5, 100, 11)
shpCSOrder.TextFrame.Characters.Text = "CS:" & Worksheets("Sheet1").Range("B48")
shpCSOrder.TextFrame.Characters.Font.Size = 11
shpCSOrder.TextFrame.MarginLeft = 0
shpCSOrder.TextFrame.MarginTop = 0
shpCSOrder.TextFrame.MarginRight = 0
shpCSOrder.TextFrame.MarginBottom = 0
shpCSOrder.TextFrame.AutoSize = True
shpCSOrder.Top = shpPartDescription.Top - shpCSOrder.Height
shpCSOrder.Left = mychart.Parent.Width - shpCSOrder.Width
If Worksheets("Sheet1").Range("B48") = "" Then shpCSOrder.Visible = msoFalse
Sheet1.Shapes("chtBarcode2Pic").Chart.Shapes("TextBox 1").TextFrame.Characters.Text = BarcodeGenerator.Code128_Str(Worksheets("Sheet1").Range("B48"))
' Erase temporary file if exists
If FileExists(TmpFolder & "bufferbarcode.jpg") Then Kill TmpFolder & "bufferbarcode.jpg"
' Output picture of barcode to file
Sheet1.Shapes("chtBarcode2Pic").Chart.Export TmpFolder & "bufferbarcode.jpg", "jpg"
Set shpCSOrderBarcode = mychart.Shapes.AddPicture(TmpFolder & "bufferbarcode.jpg", msoTrue, msoTrue, 0, 0, 100, 22)
shpCSOrderBarcode.Top = shpCSOrder.Top - shpCSOrderBarcode.Height + 3
shpCSOrderBarcode.Left = mychart.Parent.Width - shpCSOrderBarcode.Width + 3
If Worksheets("Sheet1").Range("B48") = "" Then shpCSOrderBarcode.Visible = msoFalse
Set shpSO = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, 185, 4.5, 100, 11)
shpSO.TextFrame.Characters.Text = "SO:" & Worksheets("Sheet1").Range("B29")
shpSO.TextFrame.Characters.Font.Size = 11
shpSO.TextFrame.MarginLeft = 0
shpSO.TextFrame.MarginTop = 0
shpSO.TextFrame.MarginRight = 0
shpSO.TextFrame.MarginBottom = 0
shpSO.TextFrame.AutoSize = True
shpSO.Top = shpCSOrderBarcode.Top - shpSO.Height + 3
shpSO.Left = mychart.Parent.Width - shpSO.Width
If Worksheets("Sheet1").Range("B29") = "" Then shpSO.Visible = msoFalse
Sheet1.Shapes("chtBarcode2Pic").Chart.Shapes("TextBox 1").TextFrame.Characters.Text = BarcodeGenerator.Code128_Str(Worksheets("Sheet1").Range("B29"))
' Erase temporary file if exists
If FileExists(TmpFolder & "bufferbarcode.jpg") Then Kill TmpFolder & "bufferbarcode.jpg"
' Output picture of barcode to file
Sheet1.Shapes("chtBarcode2Pic").Chart.Export TmpFolder & "bufferbarcode.jpg", "jpg"
Set shpSOBarcode = mychart.Shapes.AddPicture(TmpFolder & "bufferbarcode.jpg", msoTrue, msoTrue, 0, 0, 100, 22)
shpSOBarcode.Top = shpSO.Top - shpSOBarcode.Height + 3
shpSOBarcode.Left = mychart.Parent.Width - shpSOBarcode.Width + 3
If Worksheets("Sheet1").Range("B29") = "" Then shpSOBarcode.Visible = msoFalse
Set shp1stMil = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, shpExportControl.Left, shpExportControl.Top + shpExportControl.Height, 100, 11)
shp1stMil.TextFrame.Characters.Text = "1st MILITARY:(" & Worksheets("Sheet1").Range("B21") & ")"
shp1stMil.TextFrame.Characters.Font.Size = 13
shp1stMil.TextFrame.MarginLeft = 0
shp1stMil.TextFrame.MarginTop = 0
shp1stMil.TextFrame.MarginRight = 0
shp1stMil.TextFrame.MarginBottom = 0
shp1stMil.TextFrame.AutoSize = True
shp1stMil.Fill.BackColor.RGB = RGB(255, 255, 255)
If Worksheets("Sheet1").Range("B21") = "" Then shp1stMil.Visible = msoFalse
Set shpPUSML = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, shpExportControl.Left, shp1stMil.Top + shp1stMil.Height, 100, 11)
shpPUSML.TextFrame.Characters.Text = "P-USML:(" & Worksheets("Sheet1").Range("B22") & ")"
shpPUSML.TextFrame.Characters.Font.Size = 13
shpPUSML.TextFrame.MarginLeft = 0
shpPUSML.TextFrame.MarginTop = 0
shpPUSML.TextFrame.MarginRight = 0
shpPUSML.TextFrame.MarginBottom = 0
shpPUSML.TextFrame.AutoSize = True
shpPUSML.Fill.BackColor.RGB = RGB(255, 255, 255)
If Worksheets("Sheet1").Range("B22") = "" Then shpPUSML.Visible = msoFalse
Set shpUSML = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, shpExportControl.Left, shpPUSML.Top + shpPUSML.Height, 100, 11)
shpUSML.TextFrame.Characters.Text = "USML:(" & Worksheets("Sheet1").Range("B23") & ")"
shpUSML.TextFrame.Characters.Font.Size = 13
shpUSML.TextFrame.MarginLeft = 0
shpUSML.TextFrame.MarginTop = 0
shpUSML.TextFrame.MarginRight = 0
shpUSML.TextFrame.MarginBottom = 0
shpUSML.TextFrame.AutoSize = True
shpUSML.Fill.BackColor.RGB = RGB(255, 255, 255)
If Worksheets("Sheet1").Range("B23") = "" Then shpUSML.Visible = msoFalse
Set shpITARCID = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, shpExportControl.Left, shpUSML.Top + shpUSML.Height, 100, 11)
shpITARCID.TextFrame.Characters.Text = "ITAR CID:(" & Worksheets("Sheet1").Range("B24") & ")"
shpITARCID.TextFrame.Characters.Font.Size = 13
shpITARCID.TextFrame.MarginLeft = 0
shpITARCID.TextFrame.MarginTop = 0
shpITARCID.TextFrame.MarginRight = 0
shpITARCID.TextFrame.MarginBottom = 0
shpITARCID.TextFrame.AutoSize = True
shpITARCID.Fill.BackColor.RGB = RGB(255, 255, 255)
If Worksheets("Sheet1").Range("B24") = "" Then shpITARCID.Visible = msoFalse
Set shpPECCN = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, shpExportControl.Left, shpITARCID.Top + shpITARCID.Height, 100, 11)
shpPECCN.TextFrame.Characters.Text = "P-ECCN:(" & Worksheets("Sheet1").Range("B25") & ")"
shpPECCN.TextFrame.Characters.Font.Size = 13
shpPECCN.TextFrame.MarginLeft = 0
shpPECCN.TextFrame.MarginTop = 0
shpPECCN.TextFrame.MarginRight = 0
shpPECCN.TextFrame.MarginBottom = 0
shpPECCN.TextFrame.AutoSize = True
shpPECCN.Fill.BackColor.RGB = RGB(255, 255, 255)
If Worksheets("Sheet1").Range("B25") = "" Then shpPECCN.Visible = msoFalse
Set shpECCN = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, shpExportControl.Left, shpPECCN.Top + shpPECCN.Height, 100, 11)
shpECCN.TextFrame.Characters.Text = "ECCN:(" & Worksheets("Sheet1").Range("B26") & ")"
shpECCN.TextFrame.Characters.Font.Size = 13
shpECCN.TextFrame.MarginLeft = 0
shpECCN.TextFrame.MarginTop = 0
shpECCN.TextFrame.MarginRight = 0
shpECCN.TextFrame.MarginBottom = 0
shpECCN.TextFrame.AutoSize = True
shpECCN.Fill.BackColor.RGB = RGB(255, 255, 255)
If Worksheets("Sheet1").Range("B26") = "" Then shpECCN.Visible = msoFalse
Set shpECL = mychart.Shapes.AddTextbox(msoTextOrientationHorizontal, shpExportControl.Left, shpECCN.Top + shpECCN.Height, 100, 11)
shpECL.TextFrame.Characters.Text = "ECL:(" & Worksheets("Sheet1").Range("B27") & ")"
shpECL.TextFrame.Characters.Font.Size = 13
shpECL.TextFrame.MarginLeft = 0
shpECL.TextFrame.MarginTop = 0
shpECL.TextFrame.MarginRight = 0
shpECL.TextFrame.MarginBottom = 0
shpECL.TextFrame.AutoSize = True
shpECL.Fill.BackColor.RGB = RGB(255, 255, 255)
If Worksheets("Sheet1").Range("B27") = "" Then shpECL.Visible = msoFalse
End Sub
Good luck
I'm working on this code and keep getting errors. It will all compile, but I keep getting run-time errors. I'm trying to compare two different sheets and then highlight cells that do not match. I am not sure where the error(s) are occurring. Any help would be greatly appreciated.
Sub David()
Dim Initial_PO As Double
Dim Initial_Firmed As Range
Dim Initial_Agreed_Ship As Range
Dim Initial_Actual_Ship As Range
Dim Initial_Agreed_Delivery As Range
Dim Initial_Actual_Delivery As Range
Dim Initial_Requested_Quantity As Range
Dim Initial_Actual_Quantity As Range
Dim Initial_QMetric As Double
Dim Initial_DMetric As Double
Dim Final_PO As Double
Dim Final_Firmed As Range
Dim Final_Agreed_Ship As Range
Dim Final_Actual_Ship As Range
Dim Final_Agreed_Delivery As Range
Dim Final_Actual_Delivery As Range
Dim Final_Requested_Quantity As Range
Dim Final_Actual_Quantity As Range
Dim Final_QMetric As Double
Dim Final_DMetric As Double
Dim Initial_Agreed_Delivery_Date As Date
Dim Final_Agreed_Delivery_Date As Date
Dim Initial_Actual_Delivery_Date As Date
Dim Final_Actual_Delivery_Date As Date
Dim Today As Date
'Dim NumRow As Integer
Dim i As Long
Dim BulkLT As Double
For i = 2 To 3000
Sheets("Initial").Select
Set Initial_PO = Cells(i, 7)
Set Initial_Firmed = Cells(i, 9)
Set Initial_Agreed_Ship = Cells(i, 10)
Set Initial_Actual_Ship = Cells(i, 11)
Set Initial_Agreed_Delivery = Cells(i, 13)
Set Initial_Actual_Delivery = Cells(i, 14)
Set Initial_Requested_Quantity = Cells(i, 15)
Set Initial_Actual_Quantity = Cells(i, 16)
Sheets("Final").Select
Set Final_PO = Cells(i, 7)
Set Final_Firmed = Cells(i, 9)
Set Final_Agreed_Ship = Cells(i, 10)
Set Final_Actual_Ship = Cells(i, 11)
Set Final_Agreed_Delivery = Cells(i, 13)
Set Final_Actual_Delivery = Cells(i, 14)
Set Final_Requested_Quantity = Cells(i, 15)
Set Final_Actual_Quantity = Cells(i, 15)
'Initial Highlighting
If (Initial_PO = Final_PO) Then
If Not (Initial_Firmed = Final_Firmed) Then
Initial_Firmed.Interior.Color = RGB(225, 225, 0) And Final_Firmed.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Agreed_Ship = Final_Agreed_Ship) Then
Initial_Agreed_Ship.Interior.Color = RGB(225, 225, 0) And Final_Agreed_Ship.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Actual_Ship = Final_Actual_Ship) Then
Initial_Actual_Ship.Interior.Color = RGB(225, 225, 0) And Final_Actual_Ship.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Agreed_Delivery = Final_Agreed_Delivery) Then
Initial_Agreed_Delivery.Interior.Color = RGB(225, 225, 0) And Final_Agreed_Delivery.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Actual_Delivery = Final_Actual_Delivery) Then
Initial_Actual_Delivery.Interior.Color = RGB(225, 225, 0) And Final_Actual_Delivery.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Requested_Quantity = Final_Requested_Quantity) Then
Initial_Requested_Quantity.Interior.Color = RGB(225, 225, 0) And Final_Requested_Quantity.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Actual_Quantity = Final_Actual_Quantity) Then
Initial_Actual_Quantity.Interior.Color = RGB(225, 225, 0) And Final_Actual_Quantity.Interior.Color = RGB(225, 225, 0)
End If
If Not (Initial_Requested_Quantity = Initial_Actual_Quantity) Then
Initial_Requested_Quantity.Interior.Color = RGB(225, 225, 0) And Initial_Actual_Quantity.Interior.Color = RGB(225, 225, 0)
End If
If Not (Final_Requested_Quantity = Final_Actual_Quantity) Then
Final_Requested_Quantity.Interior.Color = RGB(225, 225, 0) And Final_Actual_Quantity.Interior.Color = RGB(225, 225, 0)
End If
'Metric Calculation
Initial_QMetric = ((Initial_Actual_Quantity / Initial_Requested_Quantity) * 100)
Final_QMetric = ((Final_Actual_Quantity / Final_Requested_Quantity) * 100)
Sheets("Initial").Select
Cells(i, 27) = Initial_QMetric
Sheets("Final").Select
Cells(i, 27) = Final_QMetric
If (Initial_QMetric < 90 Or Initial_QMetric > 110) Then
Sheets("Initial").Select
Cells(i, 27).Interior.Color = RGB(225, 225, 0)
End If
If (Final_QMetric < 90 Or Final_QMetric > 110) Then
Sheets("Final").Select
Cells(i, 27).Interior.Color = RGB(225, 225, 0)
End If
Initial_DMetric = DateDiff("d", Initial_Agreed_Delivery_Date, Initial_Actual_Delivery_Date)
Final_DMetric = DateDiff("d", Final_Agreed_Delivery_Date, Final_Actual_Delivery_Date)
Sheets("Initial").Select
Cells(i, 28) = Initial_DMetric
Sheets("Final").Select
Cells(i, 28) = Final_DMetric
If (Initial_DMetric > 5 Or Initial_DMetric < (-5)) Then
Sheets("Initial").Select
Cells(i, 28).Interior.Color = RGB(225, 225, 0)
End If
If (Final_DMetric > 5 Or Final_DMetric < (-5)) Then
Sheets("Final").Select
Cells(i, 28).Interior.Color = RGB(225, 225, 0)
End If
'Bulk Lead time
BulkLT = DateDiff("d", Today, Final_Agreed_Ship)
If IsEmpty(Final_Firmed) = True Then
If (BulkLT < 90) Then
Final_Firmed.Interior.Color = RGB(225, 225, 0)
End If
End If
Else: MsgBox ("PO Numbers in row" & i & "do not match")
End If
Next i
End
End Sub
as for the last error, you're dimming Initial_PO as a value type (Dim Initial_PO As Double) and then trying to set it as an object (Set Initial_PO = Cells(i, 7)): you choose a type (value or object) and then act consistently
furthermore you could get much more control over your code and reduce its execution time by referencing ranges and avoiding Select() method and Selection property for them
finally you're duplicating a lot of code, and this also can lead to unwanted typos and loose code control
for all what above you may want to consider this code:
Option Explicit
Sub David()
Dim initialSht As Worksheet: Set initialSht = Worksheets("Initial")
Dim finalSht As Worksheet: Set finalSht = Worksheets("Final")
Dim i As Long, lastRow As Long
lastRow = initialSht.Cells(initialSht.Rows.Count, 7).End(xlUp).Row 'get the "Initial" last non blank row index in column 7
For i = 2 To lastRow
If initialSht.Cells(i, 7) = initialSht.Cells(i, 7) Then
DoChecksAndFormat initialSht, finalSht, i
Else
MsgBox ("PO Numbers in row '" & i & "' do not match")
End If
Next i
End Sub
Sub DoChecksAndFormat(initialSht As Worksheet, finalSht As Worksheet, i As Long)
Dim Initial_Firmed As Range
Dim Initial_Agreed_Ship As Range
Dim Initial_Actual_Ship As Range
Dim Initial_Agreed_Delivery As Range
Dim Initial_Actual_Delivery As Range
Dim Initial_Requested_Quantity As Range
Dim Initial_Actual_Quantity As Range
Dim Initial_QMetric As Double
Dim Final_Firmed As Range
Dim Final_Agreed_Ship As Range
Dim Final_Actual_Ship As Range
Dim Final_Agreed_Delivery As Range
Dim Final_Actual_Delivery As Range
Dim Final_Requested_Quantity As Range
Dim Final_Actual_Quantity As Range
Dim Initial_Agreed_Delivery_Date As Date
Dim Final_Agreed_Delivery_Date As Date
Dim Initial_Actual_Delivery_Date As Date
Dim Final_Actual_Delivery_Date As Date
Dim BulkLT As Double
'initialize your relevant variables
Init initialSht, i, Initial_Firmed, Initial_Agreed_Ship, Initial_Actual_Ship, Initial_Agreed_Delivery, Initial_Actual_Delivery, Initial_Requested_Quantity, Initial_Actual_Quantity
Init finalSht, i, Final_Firmed, Final_Agreed_Ship, Final_Actual_Ship, Final_Agreed_Delivery, Final_Actual_Delivery, Final_Requested_Quantity, Final_Actual_Quantity
'Initial Highlighting
CheckAndColor Initial_Firmed, Final_Firmed
CheckAndColor Initial_Agreed_Ship, Final_Agreed_Ship
CheckAndColor Initial_Actual_Ship, Final_Actual_Ship
CheckAndColor Initial_Agreed_Delivery, Final_Agreed_Delivery
CheckAndColor Initial_Actual_Delivery, Final_Actual_Delivery
CheckAndColor Initial_Requested_Quantity, Final_Requested_Quantity
CheckAndColor Initial_Actual_Quantity, Final_Actual_Quantity
CheckAndColor Initial_Requested_Quantity, Initial_Actual_Quantity
CheckAndColor Final_Requested_Quantity, Final_Actual_Quantity
'Metric Calculation
QMetric initialSht.Cells(i, 27), Initial_Actual_Quantity.Value, Initial_Requested_Quantity.Value
QMetric finalSht.Cells(i, 27), Final_Actual_Quantity.Value, Final_Requested_Quantity.Value
DMetric initialSht.Cells(i, 28), Initial_Agreed_Delivery_Date, Initial_Actual_Delivery_Date
DMetric finalSht.Cells(i, 28), Final_Agreed_Delivery_Date, Final_Actual_Delivery_Date
'Bulk Lead time
BulkLT = DateDiff("d", Now, Final_Agreed_Ship)
If IsEmpty(Final_Firmed) Then
If BulkLT < 90 Then Final_Firmed.Interior.Color = RGB(225, 225, 0)
End If
End Sub
Sub Init(sht As Worksheet, i As Long, Firmed As Range, Agreed_Ship As Range, Actual_Ship As Range, Agreed_Delivery As Range, Actual_Delivery As Range, Requested_Quantity As Range, Actual_Quantity As Range)
With sht
Set Firmed = .Cells(i, 9)
Set Agreed_Ship = .Cells(i, 10)
Set Actual_Ship = .Cells(i, 11)
Set Agreed_Delivery = .Cells(i, 13)
Set Actual_Delivery = .Cells(i, 14)
Set Requested_Quantity = .Cells(i, 15)
Set Actual_Quantity = .Cells(i, 16)
End With
End Sub
Sub CheckAndColor(rng1 As Range, rng2 As Range)
If Not (rng1 = rng2) Then rng1.Interior.Color = RGB(225, 225, 0) And rng2.Interior.Color = RGB(225, 225, 0)
End Sub
Sub QMetric(rng As Range, Actual_Quantity As Double, Requested_Quantity As Double)
Dim QMetric As Double
QMetric = (Actual_Quantity / Requested_Quantity) * 100
rng.Value = QMetric
If (QMetric < 90 Or QMetric > 110) Then rng.Interior.Color = RGB(225, 225, 0)
End Sub
Sub DMetric(rng As Range, Agreed_Delivery_Date As Date, Actual_Delivery_Date As Date)
Dim DMetric As Double
DMetric = DateDiff("d", Agreed_Delivery_Date, Actual_Delivery_Date)
rng.Value = DMetric
If (DMetric > 5 Or DMetric < -5) Then rng.Interior.Color = RGB(225, 225, 0)
End Sub
where I also made some little adjustments:
for example in your code you wrote:
Set Initial_Actual_Quantity = Cells(i, 16)
...
Set Final_Actual_Quantity = Cells(i, 15)
and I assumed that column 16 would do for both sheets
I have a code to change the colors of my bars in my bar graph but now it gives me a type mismatch. Please help me fix my code.
Sub UpdateChart()
Dim myChartObj As ChartObject
Dim myChart As Chart
Dim mySeries(1 To 10) As Series
Dim myChartFormat(1 To 10) As ChartFormat
Dim myFillFormat(1 To 10) As FillFormat
Dim myColorFormat(1 To 10) As ColorFormat
ActiveSheet.ChartObjects(1).Activate
Set myChart = ActiveChart
For i = 1 To 10
Set mySeries(i) = myChart.SeriesCollection(i)
Set myChartFormat(i) = mySeries(i).Format
Set myFillFormat(i) = myChartFormat(i).Fill
Set myColorFormat(i) = myFillFormat(i).ForeColor
If i = 1 Then
myColorFormat(i).RGB = getRGB1(Cells(12, 7))
ElseIf i = 2 Then
myColorFormat(i).RGB = getRGB1(Cells(12, 7))
ElseIf i = 3 Then
myColorFormat(i).RGB = getRGB1(Cells(12, 8))
ElseIf i = 4 Then
myColorFormat(i).RGB = getRGB1(Cells(12, 9))
ElseIf i = 5 Then
myColorFormat(i).RGB = getRGB1(Cells(12, 10))
ElseIf i = 6 Then
myColorFormat(i).RGB = getRGB1(Cells(12, 11))
ElseIf i = 7 Then
myColorFormat(i).RGB = getRGB1(Cells(12, 12))
ElseIf i = 8 Then
myColorFormat(i).RGB = getRGB1(Cells(12, 13))
ElseIf i = 9 Then
myColorFormat(i).RGB = getRGB1(Cells(12, 14))
ElseIf i = 10 Then
myColorFormat(i).RGB = getRGB1(Cells(12, 15))
End If
Next i
End Sub
Function getRGB1(rcell) As String
Dim sColor As String
sColor = Right("000000" & Hex(rcell.Interior.Color), 6)
getRGB1 = Right(sColor, 2) & Mid(sColor, 3, 2) & Left(sColor, 2)
End Function
Set the color of each cell in range G12:R12
Option Explicit
Sub UpdateChart()
Dim myChart As Chart
Set myChart = ActiveSheet.ChartObjects(1)
For i = 1 To 10
With myChart.SeriesCollection(1)
.Points(i).Format.Fill.ForeColor.RGB = Cells(12, i + 6).Interior.Color
End With
End Sub
End Sub
With the code below I am receiving the 438 error when I try to move a slide to a section that has already been created. Last 4 lines of the code.
Sorry if this code is not clear, but I am new to VBA.
Private Sub CopyandPastetoPPT(Counter As Integer)
Dim NextShape As Integer
Dim IssueName As String
Dim IssueDesc As String
Dim CfoNumber As String
Dim IndName As String
Dim Cat1 As Variant
IssueName = Worksheets("Data_Sheet").Cells(Counter, 1)
IssueDesc = Worksheets("Data_Sheet").Cells(Counter, 3)
CfoNumber = Worksheets("Data_Sheet").Cells(Counter, 5)
IndName = Worksheets("Data_Sheet").Cells(Counter, 7)
Cat1 = Worksheets("Data_Sheet").Cells(Counter, 9)
Set PP_Slide = PP_File.Slides(Counter + 1)
PP_Slide.Shapes.AddShape Type:=msoShapeRectangle, _
Left:=0, Top:=0, Width:=276, Height:=59
NextShape = PP_Slide.Shapes.Count
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Text = IssueName
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Font.Size = 16
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Font.Color = vbBlack
PP_Slide.Shapes(NextShape).TextFrame.VerticalAnchor = msoAnchorMiddle
PP_Slide.Shapes.AddShape Type:=msoShapeRectangle, _
Left:=276, Top:=0, Width:=153, Height:=59
NextShape = PP_Slide.Shapes.Count
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Text = IssueDesc
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Font.Size = 16
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Font.Color = vbWhite
PP_Slide.Shapes(NextShape).TextFrame.TextRange.ParagraphFormat.SpaceBefore = 0
PP_Slide.Shapes(NextShape).TextFrame.VerticalAnchor = msoAnchorMiddle
PP_Slide.Shapes(NextShape).Fill.BackColor.RGB = RGB(0, 0, 0)
PP_Slide.Shapes.AddShape Type:=msoShapeRectangle, _
Left:=199, Top:=59, Width:=77, Height:=30
NextShape = PP_Slide.Shapes.Count
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Text = CfoNumber
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Font.Size = 10
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Font.Bold = False
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Font.Color = vbBlack
PP_Slide.Shapes(NextShape).TextFrame.TextRange.ParagraphFormat.SpaceBefore = 0
PP_Slide.Shapes(NextShape).TextFrame.VerticalAnchor = msoAnchorMiddle
PP_Slide.Shapes(NextShape).Line.Visible = False
PP_Slide.Shapes.AddShape Type:=msoShapeRectangle, _
Left:=597, Top:=507, Width:=123, Height:=18
NextShape = PP_Slide.Shapes.Count
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Text = IndName
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Font.Size = 10
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Font.Italic = True
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Font.Bold = False
PP_Slide.Shapes(NextShape).TextFrame.TextRange.Font.Color = vbBlack
PP_Slide.Shapes(NextShape).TextFrame.TextRange.ParagraphFormat.SpaceBefore = 0
PP_Slide.Shapes(NextShape).TextFrame.VerticalAnchor = msoAnchorMiddle
PP_Slide.Shapes(NextShape).Line.Visible = False
If Cat1 = "Center Consoles" Then
PP_Slide.MoveToSection "Center Consoles"
End If
End Sub