i have code that can extract from excel to PowerPoint but sometime shows automation error
i tried using return but it doesn't work
can u plz help me with this issue?
this is my code so far:
'''
Sub presntation()
Dim pptapp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
'Declare Excel Variables
Dim ExcRng As Range
Dim RngArray As Variant
Dim RngArray1 As Variant
' On Error Resume Next
' x = x - 1
' e = e - 1
' h = h - 1
Dim oPPTApp As PowerPoint.Application
Dim oPPTFile As PowerPoint.Presentation
Dim oPPTShape As PowerPoint.Shape
Dim oPPTSlide As PowerPoint.Slide
'intger ma jjsjks kskjsdkjsd
Dim Rng As Range
Dim h As Integer
Dim v As Integer
'intger1111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111
Dim m As Integer
Dim s As Integer
p = 0
On Error GoTo errhandler
'errhandler:
'Resume Next
Dim g As Integer
Dim e As Integer
Dim p As Integer
'Do
'DoEvents
'Loop Until ie.readstate = readystate_complete
'Tate Complete
'Get the PowerPoint Application, I am assuming it's already open.
Set pptapp = New PowerPoint.Application
pptapp.Visible = True
Set oPPTApp = GetObject(, "PowerPoint.Application")
'Set a reference to the range you want to copy, and then copy it.
'Set Rng = Worksheets("Sheet1").Range("B3:N9")
' Rng.Copy
'Set a reference to the active presentation.
g = 0
m = 0
Dim o As Integer
o = 0
h = 1
e = 0
x = 0
errhandler:
If p = 1 Then
oPPTFile.Slides(s).Delete
If x = 0 Then
GoTo Go
'
Else
If x = Even.Value = True Then
s = s - 1
'x = x - 1
e = e - 1
GoTo Go
Else
s = s - 1
x = x - 2
e = e - 2
GoTo Go
End If
End If
Else
End If
'Populate our array
' If x = 0 Then
' Sheets("WBB2").Select
' Else
' If x = 1 Then
' Sheets("WBB3").Select
' Else
' End If
'End If
'Create a new instance of PowerPoint
s = 1
e = 0
' Set pptapp = New PowerPoint.Application
' pptapp.Visible = True
'Create a new Presentation
Set PPTPres = pptapp.Presentations.Add
'RngArray = Array(Worksheets("Backup data1").Range("E9:O38"))
RngArray = Array(Worksheets("Backup data1").Range("E9:O38"), Worksheets("Backup
data1").Range("E6:O8"), Worksheets("Backup data1").Range("E50:O79"), Worksheets("Backup
data1").Range("E47:O49"), Worksheets("Backup data1").Range("E87:O116"), Worksheets("Backup
data1").Range("E84:O86"), Worksheets("Backup data1").Range("E127:O156"), Worksheets("Backup
data1").Range("E123:O125"), Worksheets("Backup data1").Range("E165:O195"), Worksheets("Backup
data1").Range("E163:O165"), Worksheets("Backup data1").Range("E203:O232"), Worksheets("Backup
data1").Range("E200:O202"), Worksheets("Backup data1").Range("E241:O270"), Worksheets("Backup
data1").Range("E237:O239"), Worksheets("Backup data1").Range("C307:L314"), Worksheets("Backup
data1").Range("D301:K303"), Worksheets("Backup data1").Range("C335:L340"), Worksheets("Backup
data1").Range("D329:K331"), Worksheets("Backup data1").Range("C365:L372"), Worksheets("Backup
data1").Range("D359:K361"), _
Worksheets("Backup data1").Range("C393:L396"), Worksheets("Backup data1").Range("D387:K389"),
Worksheets("Backup data1").Range("C421:L428"), Worksheets("Backup data1").Range("D415:K417"),
Worksheets("Backup data1").Range("C449:L455"), Worksheets("Backup data1").Range("D443:K445"),
Worksheets("Backup data1").Range("C477:L479"), Worksheets("Backup data1").Range("D471:K473"),
Worksheets("Backup data1").Range("C505:L510"), Worksheets("Backup data1").Range("D499:K501"),
Worksheets("Backup data1").Range("A531:F544"), Worksheets("Backup data1").Range("B527:K529"))
'Loop through the range array, create a slide for each range, and copy that range on to the
slide.
For x = LBound(RngArray) To UBound(RngArray)
Go:
'Set a reference to the range
Set ExcRng = RngArray(x)
'Copy Range
ExcRng.Copy
'Enable this line of code if you recieve error about the range not being in the clipboard
- This will fix that error by pausing the program for ONE Second.
Set oPPTFile = oPPTApp.ActivePresentation
If h = 1 Then
If m = 2 Then
Set oPPTSlide = Nothing
Set PPTSlide = Nothing
x = x - (1 + g)
Set PPTSlide = PPTPres.Slides.Add(x + 1, ppLayoutBlank)
' Application.Wait Now + #12:00:01 AM#
m = 1
x = x + (1 + g)
s = s + 1
g = g + 1
Else
m = m + 1
Set PPTSlide = PPTPres.Slides.Add(x + 1, ppLayoutBlank)
End If
'Set PPTSlide = PPTPres.Slides.Add(x + 1, ppLayoutBlank)
'x = x + 1
'Set a reference to the slide you want to paste it on.
Set oPPTSlide = oPPTFile.Slides(s)
Else
m = m + 1
End If
Application.Wait Now + TimeValue("00:00:02")
p = 1
'On Error GoTo errhandler
'errhandler:
'Resume Next
'WARNING THIS METHOD IS VERY VOLATILE, PAUSE THE APPLICATION TO SELECT THE SLIDE
For i = 1 To 5000: DoEvents: Next
oPPTSlide.Select
'WARNING THIS METHOD IS VERY VOLATILE, PAUSE THE APPLICATION TO PASTE THE OBJECT
For i = 1 To 10000: DoEvents: Next
oPPTApp.CommandBars.ExecuteMso "PasteSourceFormatting"
oPPTApp.CommandBars.ReleaseFocus
For i = 1 To 10000: DoEvents: Next
'
If e < 14 Then
If h = 2 Then
With oPPTApp.ActiveWindow.Selection.ShapeRange
.Top = 20
.Left = 25
.Width = 910
End With
Set oPPTSlide = Nothing
Set PPTSlide = Nothing
h = 0
'Application.Wait Now + #12:00:01 AM#
Else
With oPPTApp.ActiveWindow.Selection.ShapeRange
.Top = 80
.Left = 50
.Height = 450
.Width = 870
' Application.Wait Now + #12:00:01 AM#
End With
End If
Else
If h = 2 Then
With oPPTApp.ActiveWindow.Selection.ShapeRange
.Top = 20
.Left = 25
.Width = 910
Set oPPTSlide = Nothing
Set PPTSlide = Nothing
End With
h = 0
Else
With oPPTApp.ActiveWindow.Selection.ShapeRange
.Top = 80
.Left = 50
.Height = 300
' .Height = 200
.Width = 870
End With
End If
End If
o = o + 1
e = e + 1
'Create a new Slide
'Set PPTSlide = PPTPres.Slides.Add(x + 1, ppLayoutBlank)
'Paste the range in the slide as a linked OLEObject
'PPTApp.CommandBars.ExecuteMso
'PPTSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject
' pptApplication.CommandBars.ExecuteMso ("PasteSourceFormatting")
h = h + 1
Next x
End Sub
You're using 'Set oPPTFile = oPPTApp.ActivePresentation'
Depending what you do during the macro is running, PowerPoint might lose the focus, then the 'ActivePresentation' is empty.
Some lines before you use 'Set PPTPres = pptapp.Presentations.Add'
As a quick workaround try 'Set oPPTFile = PPTPres' instead of 'Set oPPTFile = oPPTApp.ActivePresentation', for future projects: If you already assigned an object to a variable, use this variable instead of the ActivePresentation.
It could be that you are not waiting long enough for the paste to be completed. Try the method described here
Option Explicit
Sub presntation()
' Power point variables
Dim oPPTApp As PowerPoint.Application
Dim oPPTPres As PowerPoint.Presentation
Dim oPPTShape As PowerPoint.Shape
Dim oPPTSlide As PowerPoint.Slide
' Excel Variables
Dim xl As Excel.Application
Dim wb As Workbook
Dim i As Long, RngArray As Variant, p As Integer, t0 As Single
Dim n As Integer
t0 = Timer
RngArray = Array("E9:O38", "E6:O8", "E50:O79", "E47:O49", _
"E87:O116", "E84:O86", "E127:O156", "E123:O125", _
"E165:O195", "E163:O165", "E203:O232", "E200:O202", _
"E241:O270", "E237:O239", "C307:L314", "D301:K303", _
"C335:L340", "D329:K331", "C365:L372", "D359:K361", _
"C393:L396", "D387:K389", "C421:L428", "D415:K417", _
"C449:L455", "D443:K445", "C477:L479", "D471:K473", _
"C505:L510", "D499:K501", "A531:F544", "B527:K529")
' Get the PowerPoint Application, I am assuming it's already open.
'Set oPPTApp = GetObject(, "PowerPoint.Application")
' Create new presentation
Set oPPTApp = New PowerPoint.Application
oPPTApp.Visible = msoTrue
Set oPPTPres = oPPTApp.Presentations.Add(msoTrue)
' create slides
Set wb = ThisWorkbook
Set xl = wb.Parent
For i = LBound(RngArray) To UBound(RngArray) Step 2
' create slide
If i Mod 2 = 0 Then
p = p + 1
oPPTPres.Slides.Add p, ppLayoutBlank
End If
xl.StatusBar = "Creating slide " & p
Set oPPTSlide = oPPTPres.Slides(p)
oPPTSlide.Select
'Copy Top Range
wb.Worksheets("Backup data1").Range(RngArray(i + 1)).Copy
n = oPPTSlide.Shapes.Count
oPPTApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"
' wait for shape to be created
Do
DoEvents
Loop Until oPPTSlide.Shapes.Count > n
With oPPTSlide.Shapes(oPPTSlide.Shapes.Count)
.Top = 20
.Left = 25
.Width = 910
End With
xl.CutCopyMode = False
'Copy Bottom Range
wb.Worksheets("Backup data1").Range(RngArray(i)).Copy
n = oPPTSlide.Shapes.Count
oPPTApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"
' wait for shape to be created
Do
DoEvents
Loop Until oPPTSlide.Shapes.Count > n
With oPPTSlide.Shapes(oPPTSlide.Shapes.Count)
.Top = 80
.Left = 50
.Width = 870
If i < 14 Then
.Height = 450
Else
.Height = 300
End If
End With
xl.CutCopyMode = False
Next i
AppActivate xl.Caption
xl.StatusBar = "Done"
MsgBox p & " slides created", vbSystemModal, Format(Timer - t0, "0.0 secs")
End Sub
Related
I get the icons for popup menus with two different codes. Why are they different if they have the same FaceID?
Not only the type of icons (one type Excel 2003 and another Excel 365) There are also different icons, as we can be seen in the image.
What code should I use in my popup menu to get the Excel 365 style?
I create my popup menu with this code and I can't get the Excel 365 icon:
With Application.CommandBars.Add(Name:=gsMENUNOTES, _
Position:=msoBarPopup, MenuBar:=False, Temporary:=True)
With .Controls.Add(Type:=msoControlButton)
.Caption = "New note"
.OnAction = "NewNote"
.FaceId = 4385
End With
End With
This is the code to get the icons (Excel 365 type) on the Ribbon (https://stackoverflow.com/a/18364215/11185212)
Option Explicit
Const APP_NAME = "FaceIDs (Browser)"
' The number of icons to be displayed in a set.
Const ICON_SET = 30
Sub BarOpen()
Dim xBar As CommandBar
Dim xBarPop As CommandBarPopup
Dim bCreatedNew As Boolean
Dim n As Integer, m As Integer
Dim k As Integer
On Error Resume Next
' Try to get a reference to the 'FaceID Browser' toolbar if it exists and delete it:
Set xBar = CommandBars(APP_NAME)
On Error GoTo 0
If Not xBar Is Nothing Then
xBar.Delete
Set xBar = Nothing
End If
Set xBar = CommandBars.Add(Name:=APP_NAME, Temporary:=True) ', Position:=msoBarLeft
With xBar
.Visible = True
'.Width = 80
For k = 0 To 4 ' 5 dropdowns, each for about 1000 FaceIDs
Set xBarPop = .Controls.Add(Type:=msoControlPopup) ', Before:=1
With xBarPop
.BeginGroup = True
If k = 0 Then
.Caption = "Face IDs " & 1 + 1000 * k & " ... "
Else
.Caption = 1 + 1000 * k & " ... "
End If
n = 1
Do
With .Controls.Add(Type:=msoControlPopup) '34 items * 30 items = 1020 faceIDs
.Caption = 1000 * k + n & " ... " & 1000 * k + n + ICON_SET - 1
For m = 0 To ICON_SET - 1
With .Controls.Add(Type:=msoControlButton) '
.Caption = "ID=" & 1000 * k + n + m
.FaceId = 1000 * k + n + m
End With
Next m
End With
n = n + ICON_SET
Loop While n < 1000 ' or 1020, some overlapp
End With
Next k
End With 'xBar
End Sub
And this is the code to get the icons (Excel 2003 type) on the sheet (https://www.mrexcel.com/board/threads/face-id-in-column-with-their-names-in-excel-sheet-using-vba.567230/)
Option Explicit
Sub exa()
Dim CB As CommandBar
Dim ctl As CommandBarButton
Dim strCBName As String
Dim wbTemp As Workbook
Dim wks As Worksheet
Dim rngInput As Range
Dim i As Long
Application.ScreenUpdating = False
Set wbTemp = Workbooks.Add(xlWBATWorksheet)
wbTemp.SaveAs ThisWorkbook.Path & "\FaceID.xlsx"
Dim NID As Long
Dim NSheet As Long
For NSheet = 1 To 5
'// Add a temp commandbar, make it a popup (which we won't show); add a temp control //
Set CB = CommandBars.Add(Position:=msoBarPopup, MenuBar:=False, Temporary:=True)
Set ctl = CB.Controls.Add(Type:=msoControlButton, Temporary:=True)
strCBName = CB.Name
Set wks = wbTemp.Worksheets(NSheet)
Dim vlFrom As Long
vlFrom = ((NSheet - 1) * 50 * 20) + 1
Dim vlTo As Long
vlTo = NSheet * 50 * 20
wks.Name = "F.ID " & vlFrom & "-" & vlTo
Dim Col As Integer
For Col = 2 To 40 Step 2
Dim LCol As String
LCol = Split(wks.Cells(1, Col).Address, "$")(1)
Set rngInput = wks.Range(LCol & ":" & LCol)
rngInput.Offset(, -1).ColumnWidth = 3
rngInput.ColumnWidth = 8
rngInput.HorizontalAlignment = xlRight
On Error Resume Next
For i = 1 To 50
NID = NID + 1
ctl.FaceId = NID
ctl.CopyFace
rngInput.Cells(i).PasteSpecial
rngInput.Cells(i).Value = NID
Next i
Next Col
'// just so the last image pasted doesn't stay selected//
Application.GoTo wks.Cells(1, 1)
wbTemp.Sheets.Add After:=wbTemp.Sheets(wbTemp.Sheets.Count)
'Debug.Print NSheet
'DoEvents
'// Kill the temp cbar and ctrl //
Set CB = CommandBars(strCBName)
On Error GoTo 0
If Not CB Is Nothing Then
CB.Delete
Else
MsgBox "ACK! I lost a toolbar!", 0, vbNullString
End If
Next NSheet
wbTemp.Save
End Sub
I need the expert help in VBA Excel code. I need to find the number of duplicate record (AlertToString) for particular device serial number from the source sheet serial number and paste it to the other newly created output sheet by using VBA Macro.
Example (Source sheet):
Expected (Output Sheet with repeat Alert count) :
Source code as below :
Sub Alert700Count()
Dim AlertSource_Sh As Worksheet
Dim AlertOutput_Sh As Worksheet
'Insert a New Blank Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("AlertOutput").Delete
Sheets.Add.Name = "AlertOutput"
Application.DisplayAlerts = True
Set AlertSource_Sh = ThisWorkbook.Sheets("SourceSheet")
Set AlertOutput_Sh = ThisWorkbook.Sheets("AlertOutput")
AlertOutput_Sh.Cells(1, 1) = "Serial No"
AlertOutput_Sh.Cells(1, 2) = "A92"
AlertOutput_Sh.Cells(1, 3) = "A95"
AlertOutput_Sh.Cells(1, 4) = "A98"
For Each sh In ActiveWorkbook.Worksheets
With sh.Range("A1:D1")
.Font.Bold = True
.WrapText = True
.CellWidth = 35
.Selection.Font.ColorIndex = 49
.Weight = xlMedium
.LineStyle = xlDash
End With
Next sh
AlertOutput_Sh.Range("A1:D1").Borders.Color = RGB(10, 201, 88)
AlertOutput_Sh.Columns("A:D").ColumnWidth = 12
AlertOutput_Sh.Range("A1:D1").Font.Color = rgbBlueViolet
AlertOutput_Sh.Range("A1:D1").Interior.Color = vbYellow
AlertOutput_Sh.Range("A1:D1").HorizontalAlignment = xlCenter
AlertOutput_Sh.Range("A1:D1").VerticalAlignment = xlTop
' Search the duplicate record and paste in output sheet
Dim A92Count As Long
A92Count = Application.CountIf(AlertSource_Sh.Range("D:D"), "A92")
AlertOutput_Sh.Cells(2, 2) = A92Count
Dim A95Count As Long
A95Count = Application.CountIf(AlertSource_Sh.Range("D:D"), "A95")
AlertOutput_Sh.Cells(2, 3) = A92Count
Dim A98Count As Long
A98Count = Application.CountIf(AlertSource_Sh.Range("D:D"), "A98")
AlertOutput_Sh.Cells(2, 4) = A98Count
End Sub
Current Output :
Use Dictionaries to build lists of unique values and an array to hold the counts.
Option Explicit
Sub Alert700Count()
Dim wsData As Worksheet, wsOut As Worksheet
Dim dictSerNo As Object, dictAlert As Object
Dim arData, arOut, k, rngOut As Range
Dim lastrow As Long, i As Long
Dim serNo As String, alert As String
Dim r As Long, c As Long, t0 As Single: t0 = Timer
Set dictSerNo = CreateObject("Scripting.Dictionary")
Set dictAlert = CreateObject("Scripting.Dictionary")
On Error Resume Next
Application.DisplayAlerts = False
Sheets("AlertOutput").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Sheets.Add.Name = "AlertOutput"
Set wsOut = Sheets("AlertOutput")
Set wsData = Sheets("SourceSheet")
r = 1: c = 1
With wsData
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
arData = .Range("A1:D" & lastrow).Value2
' get unique serno and alert
For i = 2 To lastrow
serNo = arData(i, 1)
alert = arData(i, 4)
If dictSerNo.exists(serNo) Then
ElseIf Len(serNo) > 0 Then
r = r + 1
dictSerNo.Add serNo, r
End If
If dictAlert.exists(alert) Then
ElseIf Len(alert) > 0 Then
c = c + 1
dictAlert.Add alert, c
End If
Next
' rescan for counts
ReDim arOut(1 To r, 1 To c)
For i = 2 To lastrow
r = dictSerNo(CStr(arData(i, 1)))
c = dictAlert(CStr(arData(i, 4)))
arOut(r, c) = arOut(r, c) + 1
Next
End With
' add headers
arOut(1, 1) = "Serial No"
' sernos and alerts
For Each k In dictSerNo
arOut(dictSerNo(k), 1) = k
Next
For Each k In dictAlert
arOut(1, dictAlert(k)) = k
Next
' output counts
With wsOut
Set rngOut = .Range("A1").Resize(UBound(arOut), UBound(arOut, 2))
rngOut.Value2 = arOut
rngOut.Replace "", 0
.ListObjects.Add(xlSrcRange, rngOut, , xlYes).Name = "Table1"
.Range("A1").AutoFilter
.Range("A1").Select
End With
MsgBox "Done", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
I haven't used Excel in a while, but now I need to. I've been Googling for a bit, but I can't seem to find an answer for my question. Basically, I'm trying to find a way to get the details from the properties of ALL connection strings, marrying other data sources to Excel. Here is a screen shot of what I want to grab. So, if there are several connections strings, I want to collect the details of each one.
This is what I have experimented with.
Sub List_Connections()
Dim wb As Workbook
Dim ws As Worksheet
Dim listObj As ListObject
Dim qt As QueryTable
Dim qtName As String
Dim n As Long
Dim wbConn As WorkbookConnection
Dim qcSheet As Worksheet, r As Long
'Either operate on this macro workbook
'Set wb = ThisWorkbook
'Or operate on the active workbook
Set wb = ActiveWorkbook
Set qcSheet = GetWbSheet(wb, "Queries Conns")
If qcSheet Is Nothing Then
With wb
Set qcSheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
qcSheet.Name = "Queries Conns"
End With
End If
qcSheet.Cells.Clear
r = 1
qcSheet.Cells(r, "A").Value = "QueryTables"
qcSheet.Cells(r, "A").Font.Bold = True
r = r + 1
qcSheet.Cells(r, "A").Resize(, 3).Value = Array("Worksheet", "QueryTable Name", "QueryTable CommandText")
r = r + 1
For Each ws In wb.Worksheets
If Not ws Is qcSheet Then
qcSheet.Cells(r, "A").Value = ws.Name
n = 0
For Each qt In ws.QueryTables
qcSheet.Cells(r + n, "B").Value = qt.Name
qcSheet.Cells(r + n, "C").Value = qt.CommandText
n = n + 1
Next
If n = 0 Then n = 1
r = r + n
End If
Next
r = r + 1
qcSheet.Cells(r, "A").Value = "ListObjects"
qcSheet.Cells(r, "A").Font.Bold = True
r = r + 1
qcSheet.Cells(r, "A").Resize(, 4).Value = Array("Worksheet", "Name", "QueryTable Name", "QueryTable CommandText")
r = r + 1
For Each ws In wb.Worksheets
If Not ws Is qcSheet Then
n = 0
For Each listObj In ws.ListObjects
qcSheet.Cells(r + n, "A").Value = ws.Name
qcSheet.Cells(r + n, "B").Value = listObj.Name
Set qt = Nothing
On Error Resume Next
Set qt = listObj.QueryTable
On Error GoTo 0
If Not qt Is Nothing Then
qtName = "Undefined"
On Error Resume Next
qtName = qt.Name
On Error GoTo 0
qcSheet.Cells(r + n, "C").Value = qtName
qcSheet.Cells(r + n, "D").Value = qt.CommandText
End If
n = n + 1
Next
r = r + n
End If
Next
r = r + 1
qcSheet.Cells(r, "A").Value = "Workbook Connections"
qcSheet.Cells(r, "A").Font.Bold = True
r = r + 1
qcSheet.Cells(r, "A").Resize(, 2).Value = Array("Name", "CommandText")
r = r + 1
n = 0
For Each wbConn In wb.Connections
qcSheet.Cells(r + n, "A").Value = wbConn.Name
Select Case wbConn.Type
Case Is = xlConnectionTypeODBC
qcSheet.Cells(r + n, "B").Value = wbConn.ODBCConnection.CommandText
Case Is = xlConnectionTypeOLEDB
qcSheet.Cells(r + n, "B").Value = wbConn.OLEDBConnection.CommandText
End Select
n = n + 1
Next
End Sub
Private Function GetWbSheet(wb As Workbook, sheetName As String) As Worksheet
Set GetWbSheet = Nothing
On Error Resume Next
Set GetWbSheet = wb.Worksheets(sheetName)
On Error Resume Next
End Function
Before:
After:
I don't know what the final code would look like, but if Excel knows what the connection string is, I think it should be exposed in some way, and accessible through VBA. Thoughts? Suggestions?
Thanks #Rory! I was able to fix it and now I got a new bug
Run time error 1004/parameter not valid
at at .SeriesCollection(j).XValues = ws.Range(rs)
Could someone please help me?
'''
I am trying to make multiple charts. And each chart would have 20 different groups with legend.
The way I have tried is first make multiple charts by columns and then add for/n loop in my code (here tried to have every 20 rows for one each group
Sub horizontal()
Dim sh As Shape
Dim ws As Worksheet
Dim ch As Chart
Dim rd As Range
Dim i As Integer, j As Integer, k As Integer
Set ws = Sheets("S1")
On Error Resume Next
ws.ChartObjects.Delete
On Error GoTo 0
For i = 20 To 45
Set rs = ws.Range("s2:s21")
Set rd = ws.Range("f1:j10")
Set sh = ws.Shapes.AddChart2(240, xlXYScatterLines)
Set ch = sh.Chart
For j = 1 To 20
k = j * 20
With ch 'shape.chart'
.SetSourceData Union(rs, ws.Range(ws.Cells(2, i), ws.Cells(21, i)))
.SeriesCollection.NewSeries
.SeriesCollection(j).XValues = ws.Range("s2:s21")
.SeriesCollection(j).Values = ws.Range(ws.Cells(k - 18, i), ws.Cells(k + 1, i))
.HasTitle = True
.ChartTitle.Text = ws.Range("T1")
.HasLegend = True
End With
Next j
With sh
.Name = "cht" & (i - 19)
.Top = (i - 20) * rd.Height
.Left = rd.Left
.Width = rd.Width
.Height = rd.Height
End With
Next i
End Sub
I tried the below two codes but they didn'twork.
Sub horizontal()
Dim sh As Shape
Dim ws As Worksheet
Dim ch As Chart
Dim rd As Range
Dim i As Integer, j As Integer, k As Integer
Set ws = Sheets("S1")
On Error Resume Next
ws.ChartObjects.Delete
On Error GoTo 0
For i = 20 To 45
Set rs = ws.Range("s2:s21")
Set rd = ws.Range("f1:j10")
Set sh = ws.Shapes.AddChart2(240, xlXYScatterLines)
Set ch = sh.Chart
With ch 'shape.chart'
.SetSourceData Union(rs, Range(Cells(2, i), Cells(21, i)))
.HasTitle = True
.ChartTitle.Text = ws.Range("T1")
.HasLegend = True
End With
With sh
.Name = "cht" & (i - 19)
.Top = (i - 20) * rd.Height
.Left = rd.Left
.Width = rd.Width
.Height = rd.Height
End With
Next i
End Sub
Sub diameter()
Dim ws As Worksheet
Dim sh As Shape
Dim ch As Chart
Dim rng As Range, rngTime As Range
Dim n As Integer, m As Integer, k As Integer, i As Integer
Set ws = Sheets("S1")
'delete previous plots
If ws.ChartObjects.Count > 0 Then
ws.ChartObjects.Delete
End If
Set rngTime = ws.Range(Cells(2, 19), Cells(21, 19))
ws.Shapes.AddChart2(240, xlXYScatterLines).Select
ws.Shapes(1).Chart.SetSourceData Union(rngTime, Range(Cells(2, 20), Cells(21, 20)))
'Source:=Range("'S1'!$S$2:$S$21,'S1'!$T$2:$T$21")
For n = 1 To 20
m = n * 20
With ActiveChart.SeriesCollection.NewSeries
ActiveChart.FullSeriesCollection(n).XValues = ws.Range(Cells(2, 19), Cells(21, 19))
ActiveChart.FullSeriesCollection(n).Values = ws.Range(Cells(m - 18, 20), Cells(m + 1, 20))
End With
Next n
End Sub
'''
Sub Click()
Dim vFile As Variant
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet
Set wbCopyTo = ActiveWorkbook
Set wsCopyTo = ActiveSheet
'-------------------------------------------------------------
'Open file with data to be copied
vFile = Application.GetOpenFilename("Excel Files (*.xlsx*)," & _"*.xlsx*", 1, "Select Excel File", "Open", False)
'If Cancel then Exit
If TypeName(vFile) = "Boolean" Then
Exit Sub
Else
Set wbCopyFrom = Workbooks.Open(vFile)
Set wsCopyFrom = wbCopyFrom.Worksheets("Corrosion")
End If
'--------------------------------------------------------------
'comparing data and copy range
Dim n, i, j, k, l, o, w, s As Double
n = wbCopyFrom.Worksheets("Corrosion").Cells(12, 3).Value
s = wbCopyFrom.Worksheets("Corrosion").Cells(22 + k, 3).Value
w = wbCopyTo.ActiveSheet("Investigation Summary").Cells(8045 + j, 5).Value
If (w = s) Then
o = 8 + j
dbln = "Y" & o
dblq = "BB" & o
dblt = "BK" & o
dblu = "BM" & o
wsCopyFrom.Range(dblm, dblp).Copy
wsCopyTo.Range(dbln, dblq).PasteSpecial Paste:=xlPasteValues
i = i + 1
k = k + 1
l = l + 1
o = 8 + j
End If
'----------------------------------------
j = j + 1
Loop
wbCopyFrom.Close SaveChanges:=False
End Sub