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
Related
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
I have made a userform which automatically adds Textboxes & Labels depending on how many rows/Columns there are in the Sheet.
Now I have a problem, for example if I had "Steve" with number like 4, it would not show the exact number in the cell Instead it will show the Row number.
Excel Data Sheet Screenshot
So what I want is to fix the Number : Label and also make the TextBox for example now if i type 1 it will show the data for the Row number 1 i want to make it work with "Steve" writing a "4" instead of a "2" Which is the row number.
Here is the Userform code:
Private Sub CommandButton1_Click()
'Exit Form
Unload Me
End Sub
Private Sub CommandButton2_Click()
'Edit
k = ScrollBar1.Value
lcol = Sheet1.Range("DX2").End(xlToLeft).Column
For j = 1 To lcol
Sheet1.Cells(k + 1, j) = Me.Controls("textbox" & j)
Next j
End Sub
Private Sub CommandButton3_Click()
'Delete
k = ScrollBar1.Value
Sheet1.Cells(k + 1, 1).EntireRow.Delete
End Sub
Private Sub ScrollBar1_Change()
Dim Rng As Range
lcol = Sheet1.Range("DX2").End(xlToLeft).Column
k = ScrollBar1.Value
k2 = TextBox1000.Value
label1000.Caption = "Number : " & k
If k <> 0 And k2 <> 0 Then
TextBox1000.Value = k
For j = 1 To lcol
Me.Controls("textbox" & j).Text = Sheet1.Cells(k, j).Offset(1, 0).Value
Next j
End If
End Sub
Private Sub TextBox1000_Change()
lcol = Sheet1.Range("DX2").End(xlToLeft).Column
k = ScrollBar1.Value
k2 = TextBox1000.Value
label1000.Caption = "Number : " & k2
If k2 <> "" Then
ScrollBar1.Value = k2
For j = 1 To lcol
Me.Controls("textbox" & j).Text = Sheet1.Cells(k2, j).Offset(1, 0).Value
Next j
End If
End Sub
Private Sub UserForm_Initialize()
Dim myLabel As Control
Dim txtbox As Control
k = ScrollBar1.Value
label1000.Caption = "Number : " & k
lcol = Sheet1.Range("DX2").End(xlToLeft).Column
For i = 1 To lcol
Set myLabel = Frame1.Controls.Add("Forms.label.1", "label" & i, True)
myLabel.Left = 250
myLabel.Top = 12 + (i * 20)
myLabel.Width = 150
myLabel.Height = 15
Set txtbox = Frame1.Controls.Add("Forms.TextBox.1", "TextBox" & i, True)
txtbox.Left = 50
txtbox.Top = 10 + (i * 20)
txtbox.Width = 180
txtbox.Height = 60
Next i
For j = 1 To lcol
With Frame1.Controls("label" & j)'Formating Labels
.Caption = Sheet1.Cells(1, j).Value
.TextAlign = fmTextAlignCenter
.Font.Bold = True
.Font.Size = 11
.FontName = "Times New Roman"
.ForeColor = vbRed
End With
With Frame1.Controls("TextBox" & j) 'Formating TextBoxes
.Text = Sheet1.Cells(1, j).Offset(1, 0).Value
.TextAlign = fmTextAlignRight
.Font.Bold = True
.Font.Size = 11
.FontName = "Times New Roman"
End With
With Frame1.Controls("TextBox1")'Make textbox1 not editable
.Enabled = False
End With
With Frame1.Controls("TextBox3")'Make textbox3 not editable
.Enabled = False
End With
Next j
End Sub
I'd say
Label1000.Caption = "Number : " & Sheet1.Cells(k + 1, 1).Value
I have made a userform that allows the user to select a table and add rows to it and fill those rows with various information, all from the userform. I have run into a few problems with this.
First after adding or during adding the items (after hitting submit) excel would crash. It occurs randomly and is hard to reproduce.
Second after running the macro there is a good chance that all the cells in the workbook and every other object except the userform button will stop working, meaning you can't edit interact or even select anything. Then when I close the workbook excel crashes after saving. This is my major offender and I think causes the other problem.
What causes this freezing and why does it occur? How do I fix it? I have looked around and haven't found anything circumstantial. One post said that I should try editing the table with no formatting on it and I did that and it didn't work.
I can provide the excel workbook at a request basis via pm.
The code:
On Activate -
Public Sub UserForm_Activate()
Set cBook = ThisWorkbook
Set dsheet = cBook.Sheets("DATA")
End Sub
Help Checkbox -
Private Sub cbHelp_Click()
If Me.cbHelp.Value = True Then
Me.lbHelp.Visible = True
Else
Me.lbHelp.Visible = False
End If
End Sub
Brand combobox -
Public Sub cmbBrand_Change()
brandTableName = cmbBrand.Value
brandTableName = CleanBrandTableName(brandTableName)
'if brand_edit is not = to a table name then error is thrown
On Error Resume Next
If Err = 380 Then
Exit Sub
Else
cmbItemID.RowSource = brandTableName
End If
On Error GoTo 0
'Set cmbItemID's text to nothing after changing to a new brand
cmbItemID.Text = ""
End Sub
CleanBrandTableName(brandTableName) function -
Option Explicit
Public Function CleanBrandTableName(ByVal brandTableName As String) As String
Dim s As Integer
Dim cleanResult As String
For s = 1 To Len(brandTableName)
Select Case Asc(Mid(brandTableName, s, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122:
cleanResult = cleanResult & Mid(brandTableName, s, 1)
Case 95
cleanResult = cleanResult & " "
Case 38
cleanResult = cleanResult & "and"
End Select
Next s
CleanBrandTableName = Replace(WorksheetFunction.Trim(cleanResult), " ", "_")
End Function
Public Function CleanSpecHyperlink(ByVal specLink As String) As String
Dim cleanLink As Variant
cleanLink = specLink
cleanLink = Replace(cleanLink, "=HYPERLINK(", "")
cleanLink = Replace(cleanLink, ")", "")
cleanLink = Replace(cleanLink, ",", "")
cleanLink = Replace(cleanLink, """", "")
cleanLink = Replace(cleanLink, "Specs", "")
CleanSpecHyperlink = cleanLink
End Function
Browse button -
Public Sub cbBrowse_Click()
Dim rPos As Long
Dim lPos As Long
Dim dPos As Long
specLinkFileName = bFile
rPos = InStrRev(specLinkFileName, "\PDFS\")
lPos = Len(specLinkFileName)
dPos = lPos - rPos
specLinkFileName = Right(specLinkFileName, dPos)
Me.tbSpecLink.Text = specLinkFileName
End Sub
bFile function -
Option Explicit
Public Function bFile() As String
bFile = Application.GetOpenFilename(Title:="Please choose a file to open")
If bFile = "" Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
Exit Function
End If
End Function
Preview button -
Private Sub cbSpecs_Click()
If specLinkFileName = "" Then Exit Sub
cBook.FollowHyperlink (specLinkFileName)
End Sub
Add Item button -
Private Sub cbAddItem_Click()
Dim brand As String
Dim description As String
Dim listPrice As Currency
Dim cost As Currency
Dim Notes As String
Dim other As Variant
itemID = Me.tbNewItem.Text
brand = Me.tbBrandName.Text
description = Me.tbDescription.Text
specLink = Replace(specLinkFileName, specLinkFileName, "=HYPERLINK(""" & specLinkFileName & """,""Specs"")")
If Me.tbListPrice.Text = "" Then
listPrice = 0
Else
listPrice = Me.tbListPrice.Text
End If
If Me.tbCost.Text = "" Then
cost = 0
Else
cost = Me.tbCost.Text
End If
Notes = Me.tbNotes.Text
other = Me.tbOther.Text
If Me.lbItemList.listCount = 0 Then
x = 0
End If
With Me.lbItemList
Me.lbItemList.ColumnCount = 8
.AddItem
.List(x, 0) = itemID
.List(x, 1) = brand
.List(x, 2) = description
.List(x, 3) = specLink
.List(x, 4) = listPrice
.List(x, 5) = cost
.List(x, 6) = Notes
.List(x, 7) = other
x = x + 1
End With
End Sub
Submit button -
Private Sub cbSubmit_Click()
Dim n As Long
Dim v As Long
Dim vTable() As Variant
Dim r As Long
Dim o As Long
Dim c As Long
Dim w As Variant
Set brandTable = dsheet.ListObjects(brandTableName)
o = 1
listAmount = lbItemList.listCount
v = brandTable.ListRows.Count
w = 0
For c = 1 To listAmount
If brandTable.ListRows(v).Range(, 1).Value <> "" Then
brandTable.ListRows.Add alwaysinsert:=True
brandTable.ListRows.Add alwaysinsert:=True
Else
brandTable.ListRows.Add alwaysinsert:=True
End If
Next
ReDim vTable(1000, 1 To 10)
For n = 0 To listAmount - 1
vTable(n + 1, 1) = lbItemList.List(n, 0)
vTable(n + 1, 2) = lbItemList.List(n, 1)
vTable(n + 1, 3) = lbItemList.List(n, 2)
vTable(n + 1, 5) = lbItemList.List(n, 4)
vTable(n + 1, 6) = lbItemList.List(n, 5)
vTable(n + 1, 7) = lbItemList.List(n, 6)
vTable(n + 1, 8) = lbItemList.List(n, 7)
If lbItemList.List(n, 3) = "" Then
ElseIf lbItemList.List(n, 3) <> "" Then
vTable(n + 1, 4) = lbItemList.List(n, 3)
End If
If n = 0 And brandTable.DataBodyRange(1, 1) <> "" Then
For r = 1 To brandTable.ListRows.Count
If brandTable.DataBodyRange(r, 1) <> "" Then
o = r + 1
' brandTable.ListRows.Add alwaysinsert:=True
End If
Next
End If
brandTable.ListColumns(1).DataBodyRange(n + o).Value = vTable(n + 1, 1)
brandTable.ListColumns(2).DataBodyRange(n + o).Value = vTable(n + 1, 2)
brandTable.ListColumns(3).DataBodyRange(n + o).Value = vTable(n + 1, 3)
brandTable.ListColumns(4).DataBodyRange(n + o).Value = vTable(n + 1, 4)
brandTable.ListColumns(5).DataBodyRange(n + o).Value = vTable(n + 1, 5)
brandTable.ListColumns(6).DataBodyRange(n + o).Value = vTable(n + 1, 6)
brandTable.ListColumns(7).DataBodyRange(n + o).Value = vTable(n + 1, 7)
brandTable.ListColumns(8).DataBodyRange(n + o).Value = vTable(n + 1, 8)
Next
brandTable.DataBodyRange.Select
Selection.Font.Bold = True
Selection.WrapText = True
brandTable.ListColumns(5).DataBodyRange.Select
Selection.NumberFormat = "$#,##0.00"
brandTable.ListColumns(6).DataBodyRange.Select
Selection.NumberFormat = "$#,##0.00"
Unload Me
End Sub
Remove Items button -
Private Sub cbRemoveItems_Click()
Dim intCount As Long
For intCount = lbItemList.listCount - 1 To 0 Step -1
If lbItemList.Selected(intCount) Then
lbItemList.RemoveItem (intCount)
x = x - 1
End If
Next intCount
End Sub
There is other code that does things for the other tabs but they don't interact with this tabs code.
I want to add many option button to an excel worksheet (not to a VBA-form) and want to group them by row. The result should look something like this:
Here is the code I'm using so far:
For d = 1 To 31
Set checkboxKrankCell = Range("H" + Trim(Str(d)))
Set checkboxUrlaubCell = Range("I" + Trim(Str(d)))
Set checkboxJazCell = Range("J" + Trim(Str(d)))
groupWidth = checkboxKrankCell.Width + checkboxUrlaubCell.Width + checkboxJazCell.Width
Set groupBoxOptionButtons = ActiveSheet.GroupBoxes.Add(checkboxKrankCell.Left - 1, checkboxKrankCell.Top - 2, groupWidth + 1, checkboxKrankCell.Height)
With groupBoxOptionButtons
.Name = "GroupBox_" + Trim(Str(d))
.Caption = ""
End With
Set checkboxKrank = ActiveSheet.OptionButtons.Add(checkboxKrankCell.Left, checkboxKrankCell.Top - 1, checkboxKrankCell.Width, checkboxKrankCell.Height)
With checkboxKrank
.Caption = ""
End With
#1 checkboxKrank.GroupBox = groupBoxOptionButtons
Set checkboxUrlaub = ActiveSheet.OptionButtons.Add(checkboxUrlaubCell.Left, checkboxUrlaubCell.Top - 1, checkboxUrlaubCell.Width, checkboxUrlaubCell.Height)
With checkboxUrlaub
.Caption = ""
End With
Set checkboxJaz = ActiveSheet.OptionButtons.Add(checkboxJazCell.Left, checkboxJazCell.Top - 1, checkboxJazCell.Width, checkboxJazCell.Height)
With checkboxJaz
.Caption = ""
#2 .GroupBox = groupBoxOptionButtons
End With
Next d
I would expect to assign the option buttons to the group for the current row by setting the GroupBox property (see #1 or #2).
But both methods just gave me an error saying 'The object does not support the property or methode'.
Any help or hint is welcome ;-)
Based on the tip from snb I have modified my function like this:
Sub AddOptionButtons()
ActiveSheet.OptionButtons.Delete
For d = 1 To 31
Set checkboxKrankCell = Range("H" + Trim(Str(d + 4)))
Set checkboxUrlaubCell = Range("I" + Trim(Str(d + 4)))
Set checkboxJazCell = Range("J" + Trim(Str(d + 4)))
option1Name = "Krank_" + Trim(Str(d))
option2Name = "Urlaub_" + Trim(Str(d))
option3Name = "Jaz_" + Trim(Str(d))
Set checkboxKrank = ActiveSheet.OptionButtons.Add(checkboxKrankCell.Left, checkboxKrankCell.Top - 1, checkboxKrankCell.Width, checkboxKrankCell.Height)
With checkboxKrank
.Caption = ""
.Name = option1Name
End With
Set checkboxUrlaub = ActiveSheet.OptionButtons.Add(checkboxUrlaubCell.Left, checkboxUrlaubCell.Top - 1, checkboxUrlaubCell.Width, checkboxUrlaubCell.Height)
With checkboxUrlaub
.Caption = ""
.Name = option2Name
End With
Set checkboxJaz = ActiveSheet.OptionButtons.Add(checkboxJazCell.Left, checkboxJazCell.Top - 1, checkboxJazCell.Width, checkboxJazCell.Height)
With checkboxJaz
.Caption = ""
.Name = option3Name
End With
ActiveSheet.Shapes.Range(Array(option1Name, option2Name, option3Name)).Group
Next d
End Sub
I don't get any errors using Shapes.Range(...).Group.
But still all option buttons from on the sheet are all mutual exclusive.
Seems grouping does not work here.
Try the following code on an empty workbook. It will give you an option to choose only ONE optionbutton on each row, which is what you want, as far as I understood (I also created a linked cell reference, just in case you would like to take further action, given the choice of a user.):
Sub AddOptionButtons()
Dim btn1 As OptionButton
Dim btn2 As OptionButton
Dim btn3 As OptionButton
Dim grbox As GroupBox
Dim t As Range
Dim s As Range
Dim p As Range
Dim i As Integer
ActiveSheet.OptionButtons.Delete
ActiveSheet.GroupBoxes.Delete
For i = 5 To 35 Step 1
Set t = ActiveSheet.Range(Cells(i, 8), Cells(i, 8))
Set s = ActiveSheet.Range(Cells(i, 9), Cells(i, 9))
Set p = ActiveSheet.Range(Cells(i, 10), Cells(i, 10))
Set btn1 = ActiveSheet.OptionButtons.Add(t.Left, t.Top, t.Width, t.Height)
Set btn2 = ActiveSheet.OptionButtons.Add(s.Left, s.Top, s.Width, s.Height)
Set btn3 = ActiveSheet.OptionButtons.Add(p.Left, p.Top, p.Width, p.Height)
Set grbox = ActiveSheet.GroupBoxes.Add(t.Left, t.Top, t.Width + 100, t.Height)
With btn1
.Caption = ""
.Display3DShading = True
.LinkedCell = "M" & i
End With
With btn2
.Caption = ""
.Display3DShading = True
End With
With btn3
.Caption = ""
.Display3DShading = True
End With
With grbox
.Caption = ""
.Visible = False
End With
Next i
End Sub
I'd use:
Sub M_snb()
ReDim sn(2)
For j = 1 To 2
For jj = 1 To 3
With Sheet1.OptionButtons.Add(Cells(j, jj).Left, Cells(j, jj).Top - 1, Cells(j, jj).Width, Cells(j, jj).Height)
sn(jj - 1) = .Name
End With
Next
Sheet1.Shapes.Range(sn).Group
Next
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