PlayerPИзвени я просто тебя не понял. Вот именно мне нужно что бы таблицы и диаграммы брались с одного листа. Иначе предаться переделывать основной файл. А он очень большой, иметься виду много таблиц и диаграмм.
Моё мнение такое что всё равно с этим где-то работать. Не разберёшь и не упорядочишь в экселе, придётся возится в поинте. Но это тебе уже решать.
Вариант для диаграмм я уже давал, осталось пробежаться по таблицам. Целесообразно наверное дать всех нужным таблицам имена, например (Лист1!таблица1 , Лист1!таблица2 ... , Лист5!таблица10), Это вставка - имя - присвоить или просто набисать в окошке где адрес ячейки пишется. Потом пробегаться по всем именам в файле и если в нём присутствует слово таблица, то копируем его.
Вот пока писал пост решил по быстрому реализовать. только не забывайте перед именами название листов указывать, а то не будут имена выбираться
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
Option Explicit
' Импортирует все графики в презентацию
Dim counter As Long
Sub ImportGraphsFromCloseFile()
Dim fileName As String
Dim i
Dim xlApp As Object
Dim xlWorkbook As Object
Dim xlSheet As Object
Dim nm As Object
' тут ничего лучшего не предумал, т.к. для корректной работы макроса нужно, чтобы
' курсор стоял именно на слайде а не там где превьюшки
' поэтому на всякий случа передёргиваю режим
With Application.ActiveWindow
ActiveWindow.ViewType = ppViewSlide
ActiveWindow.ViewType = ppViewNormal
End With
Set xlApp = CreateObject("Excel.Application")
fileName = xlApp.GetOpenFilename("Excel Files (*.xls), *.xls")
If fileName Like "" Then
MsgBox ("Выберите файл для импортирования данных")
Else
xlApp.Workbooks.Open (fileName)
Set xlWorkbook = xlApp.ActiveWorkbook
xlApp.Visible = True
counter = 1
For Each xlSheet In xlWorkbook.Sheets
If xlSheet.Name Like "Диаграмма*" Then
xlSheet.ChartArea.Copy
PasteGraphs
Else
If xlSheet.ChartObjects.Count > 0 Then
For i = 1 To xlSheet.ChartObjects.Count
xlSheet.ChartObjects(i).Chart.ChartArea.Copy
PasteGraphs
Next
End If
For Each nm In xlSheet.Names
If nm.Name Like "*таблица*" Then
nm.RefersToRange.Copy
PasteGraphs
End If
Next
End If
Next
End If
Set xlWorkbook = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub
Sub PasteGraphs()
ActivePresentation.Slides.Add(Index:=counter, Layout:=ppLayoutBlank).Select
ActiveWindow.View.PasteSpecial ppPasteOLEObject, , , , , msoTrue
' изменение размера вставленного объекта
With ActiveWindow.Selection.ShapeRange
.ScaleWidth 1 . 2 , msoFalse, msoScaleFromBottomRight
.ScaleHeight 1 . 2 , msoFalse, msoScaleFromBottomRight
.ScaleWidth 1 . 2 , msoFalse, msoScaleFromTopLeft
.ScaleHeight 1 . 2 , msoFalse, msoScaleFromTopLeft
End With
counter = counter + 1
End Sub
