Макрос загрузки в различные эксель файлы - Помощь студентам - Страница 2

KevLev · 21.04.2016, 14:19

А здесь макрос под КликВью настраивать не надо)В прошлый раз вы мне помогли с макросом "Макрос рассылка на различные адресаты"и он сразу запустился в Клике.

"А с excelя не хотите запускать?" - те 2 кнопки,что в вашем файле,я их сделаю в Клике.Здесь в любом случае в Клике придется запускать

"as integer" - удалил.Но сейчас новая ошибка

KevLev · 21.04.2016, 14:24

Если удалить и это,то появится следующая ошибка (Screenshot_13)

Aleksandr H. · 21.04.2016, 14:33

вы удалили создание нового листа

это вставка данных как числа, без формул

Вы в состоянии прокомментировать Ваш код с 1 сообщения темы?

предлагаю изменить вашу функцию

Код:

'Call Export Widgets By Sheet
Function ExportRevenueWidgets(xlDoc,xlSheet)
	ActiveDocument.GetField("ProductName").select widgetProductA
	CALL ExportWidget(xlDoc,xlSheet,WidgetID, widgetProductA)
	ActiveDocument.GetField("ProductName").Clear	
	ActiveDocument.GetField("ProductName").select widgetProductB
	CALL ExportWidget(xlDoc,xlSheet,WidgetID, widgetProductB)
	ActiveDocument.GetField("ProductName").Clear
	ActiveDocument.GetField("ProductName").select widgetProductC
	CALL ExportWidget(xlDoc,xlSheet,WidgetID, widgetProductC)
	ActiveDocument.GetField("ProductName").Clear
End Function

она сейчас сразу обрабатывает 3 widgetProduct
а что как сделать

Код:

Function ExportRevenueWidgets(xlDoc,xlSheet, widgetProductX)
	ActiveDocument.GetField("ProductName").select widgetProductX
	CALL ExportWidget(xlDoc,xlSheet,WidgetID, widgetProductX)
	ActiveDocument.GetField("ProductName").Clear	
End Function

и в exportProduct Фрагмен

Код:

Set xlDoc = xlApp.Workbooks.Add 'open new workbook
	nSheetsCount = 0
	CALL RemoveDefaultSheet(xlDoc)	
	
	nSheetsCount = xlDoc.Sheets.Count 
	xlDoc.Sheets(nSheetsCount).Select
	Set xlSheet = xlDoc.Sheets(nSheetsCount)	
	
	CALL ExportRevenueWidgets(xlDoc,xlSheet)

повторить 3 разы/запихнуть в цикл
и менять только

Код:

	CALL ExportRevenueWidgets(xlDoc,xlSheet,widgetProductX)

KevLev · 21.04.2016, 15:27

Поменял,как вы написали.Надеюсь правильно все изменил:

Код:

'Variable to hold default root folder name
Dim strRootFolder
strRootFolder = "X:\МАКРОСЫ\"

Dim reportName 
reportName="Product"

Dim WidgetID 
WidgetID = "ProductB"

Dim widgetProductA
widgetProductA = "A"

Dim widgetProductB 
widgetProductB = "B"

Dim widgetProductC 
widgetProductC = "C"

Function ExportProduct()

	CALL CheckFolderExists(strRootFolder)	

	ActiveDocument.ClearAll true
	
	Set xlApp = CreateObject("Excel.Application")
	xlApp.Visible = true		
	Set xlDoc = xlApp.Workbooks.Add 'open new workbook
	nSheetsCount = 0
	CALL RemoveDefaultSheet(xlDoc)	
	
	nSheetsCount = xlDoc.Sheets.Count 
	xlDoc.Sheets(nSheetsCount).Select
	Set xlSheet = xlDoc.Sheets(nSheetsCount)	
	
	CALL ExportRevenueWidgets(xlDoc,xlSheet,widgetProductA)	
	CALL ExportRevenueWidgets(xlDoc,xlSheet,widgetProductB)	
	CALL ExportRevenueWidgets(xlDoc,xlSheet,widgetProductC)
	'Save generated report
	xlApp.ActiveWorkBook.SaveAs strRootFolder &" "&ProductName& ".xlsx" 
	xlApp.Quit	
	
End Function

'Call Export Widgets By Sheet
Function ExportRevenueWidgets(xlDoc,xlSheet, widgetProductX)
	ActiveDocument.GetField("ProductName").select widgetProductX
	CALL ExportWidget(xlDoc,xlSheet,WidgetID, widgetProductX)
	ActiveDocument.GetField("ProductName").Clear	
End Function

'Export Widgets by Type
Function ExportWidget(xlDoc,xlSheet,widget, Value)		
	Select Case Value
		Case widgetProductA:		
			Call Export(0,xlSheet,widget,xlDoc,widgetProductA)	
		Case widgetProductB:		
			Call Export(1,xlSheet,widget,xlDoc,widgetProductB)
		Case widgetProductC:		
			Call Export(1,xlSheet,widget,xlDoc,widgetProductC)
	End Select
End Function

'Export Widgets
Function Export(IsNeedNewSheet,xlSheet,widgetID,xlDoc,sheetName)	
	
	If IsNeedNewSheet = 1 then
		CALL AddExcelSheet(xlDoc,sheetName)
		nSheetsCount = xlDoc.Sheets.Count
		xlDoc.Sheets(nSheetsCount).Select
		Set xlSheet = xlDoc.Sheets(nSheetsCount)
	Else
		xlSheet.Name = sheetName
    End If	
    
    nRow = xlSheet.UsedRange.Rows.Count
    
    If nRow > 1 Then
    	 nRow = nRow + 4
    Else
    	 nRow = nRow + 2
    End If
 
	Set SheetObj = ActiveDocument.GetSheetObject(widgetID)	
	
	ObjCaption   = SheetObj.GetCaption.Name.v
	xlSheet.Range("A"&nRow-1) = ObjCaption
	xlSheet.Range("A"&nRow-1).Font.Bold = true
	
	'Copy the chart object to clipboard
	SheetObj.CopyTableToClipboard true
	
	'Paste the chart object in Excel file
	xlSheet.Paste xlSheet.Range("A"&nRow) 		
	
	'Format the excel file	
	xlSheet.cells.Font.Size = "8"
	xlSheet.cells.Font.Name = "Tahoma"	

End Function

'Add New Sheet in Excel File
Sub AddExcelSheet(xlDoc, strSheetName)

	xlDoc.Sheets.Add, xlDoc.Sheets(xlDoc.Sheets.Count)
	Set xlSheet  = xlDoc.Sheets(xlDoc.Sheets.Count)
	xlSheet.Name = Left(strSheetName, 31)
End Sub

'Remove Default Sheets from Excel Files
Sub RemoveDefaultSheet(xlDoc)
	Do
		nSheetsCount = xlDoc.Sheets.Count
		If nSheetsCount = 1 then
			Exit Do
		Else
			xlDoc.Sheets(nSheetsCount).Select
			xlDoc.ActiveSheet.Delete
		End If
	Loop
End Sub


'Checks whether given folder exists if not creates the given folder
Function CheckFolderExists(path)	

	Set fileSystemObject = CreateObject("Scripting.FileSystemObject") 
	
	If Not fileSystemObject.FolderExists(path) Then
		fileSystemObject.CreateFolder(path) 	
	End If
	
End Function

Но строчки таблицы нарезаются опять по листам ОДНОГО эксель файла (screensgkt_14),а нужно,чтобы каждая табличка с продуктом в свой отдельный эксель файл попадала.Кажется я ваш код не правильно вставил.

Aleksandr H. · 21.04.2016, 15:43

че ж так туго все? А так?

Код:

Function ExportProduct()

    Call CheckFolderExists(strRootFolder)

    ActiveDocument.ClearAll True
    
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlDoc = xlApp.Workbooks.Add 'open new workbook
    nSheetsCount = 0
    Call RemoveDefaultSheet(xlDoc)
    
    nSheetsCount = xlDoc.Sheets.Count
    xlDoc.Sheets(nSheetsCount).Select
    Set xlSheet = xlDoc.Sheets(nSheetsCount)
    
    Call ExportRevenueWidgets(xlDoc, xlSheet, widgetProductA)
    'Save generated report
    xlApp.ActiveWorkBook.SaveAs strRootFolder &" "&ProductName&widgetProductA ".xlsx"
    xlApp.Quit
    Set xlApp = Nothing
    
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlDoc = xlApp.Workbooks.Add 'open new workbook
    nSheetsCount = 0
    Call RemoveDefaultSheet(xlDoc)
    
    nSheetsCount = xlDoc.Sheets.Count
    xlDoc.Sheets(nSheetsCount).Select
    Set xlSheet = xlDoc.Sheets(nSheetsCount)
    
    
    Call ExportRevenueWidgets(xlDoc, xlSheet, widgetProductB)
    'Save generated report
    xlApp.ActiveWorkBook.SaveAs strRootFolder &" "&ProductName&widgetProductB ".xlsx"
    xlApp.Quit
    Set xlApp = Nothing
    
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlDoc = xlApp.Workbooks.Add 'open new workbook
    nSheetsCount = 0
    Call RemoveDefaultSheet(xlDoc)
    
    nSheetsCount = xlDoc.Sheets.Count
    xlDoc.Sheets(nSheetsCount).Select
    Set xlSheet = xlDoc.Sheets(nSheetsCount)
    
    Call ExportRevenueWidgets(xlDoc, xlSheet, widgetProductC)
    'Save generated report
    xlApp.ActiveWorkBook.SaveAs strRootFolder &" "&ProductName&widgetProductC ".xlsx"
    xlApp.Quit
    Set xlApp = Nothing
End Function

KevLev · 21.04.2016, 16:13

Блин,опять загвоздка(

KevLev · 21.04.2016, 16:21

Блин,знак & пропустил

KevLev · 21.04.2016, 16:44

Снова ошибка.
Может является причиной,что в этой функции чего нет:

Код:

'Call Export Widgets By Sheet
Function ExportRevenueWidgets(xlDoc,xlSheet)
	ActiveDocument.GetField("ProductName").select widgetProductA
	CALL ExportWidget(xlDoc,xlSheet,WidgetID, widgetProductA)
	ActiveDocument.GetField("ProductName").Clear	
	ActiveDocument.GetField("ProductName").select widgetProductB
	CALL ExportWidget(xlDoc,xlSheet,WidgetID, widgetProductB)
	ActiveDocument.GetField("ProductName").Clear
	ActiveDocument.GetField("ProductName").select widgetProductC
	CALL ExportWidget(xlDoc,xlSheet,WidgetID, widgetProductC)
	ActiveDocument.GetField("ProductName").Clear
End Function

Aleksandr H. · 21.04.2016, 18:04

Третьего параметра нету. вам ж написало сверху. Я так понимаю вы отбросили мое предложение по изменению этой функции и продолжаете использовать свою. Ок,gl&hf

KevLev · 22.04.2016, 08:39

Я не отбрасываю ваше предложение.Я его применил и вот,что получилось:

Код:

Function ExportProduct()

    Call CheckFolderExists(strRootFolder)

    ActiveDocument.ClearAll True
    
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlDoc = xlApp.Workbooks.Add 'open new workbook
    nSheetsCount = 0
    Call RemoveDefaultSheet(xlDoc)
    
    nSheetsCount = xlDoc.Sheets.Count
    xlDoc.Sheets(nSheetsCount).Select
    Set xlSheet = xlDoc.Sheets(nSheetsCount)
    
    Call ExportRevenueWidgets(xlDoc, xlSheet, widgetProductA)
    'Save generated report
    xlApp.ActiveWorkBook.SaveAs strRootFolder &" "&ProductName&widgetProductA&".xlsx"
    xlApp.Quit
    Set xlApp = Nothing
    
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlDoc = xlApp.Workbooks.Add 'open new workbook
    nSheetsCount = 0
    Call RemoveDefaultSheet(xlDoc)
    
    nSheetsCount = xlDoc.Sheets.Count
    xlDoc.Sheets(nSheetsCount).Select
    Set xlSheet = xlDoc.Sheets(nSheetsCount)
    
    
    Call ExportRevenueWidgets(xlDoc, xlSheet, widgetProductB)
    'Save generated report
    xlApp.ActiveWorkBook.SaveAs strRootFolder &" "&ProductName&widgetProductB&".xlsx"
    xlApp.Quit
    Set xlApp = Nothing
    
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlDoc = xlApp.Workbooks.Add 'open new workbook
    nSheetsCount = 0
    Call RemoveDefaultSheet(xlDoc)
    
    nSheetsCount = xlDoc.Sheets.Count
    xlDoc.Sheets(nSheetsCount).Select
    Set xlSheet = xlDoc.Sheets(nSheetsCount)
    
    Call ExportRevenueWidgets(xlDoc, xlSheet, widgetProductA)
    'Save generated report
    xlApp.ActiveWorkBook.SaveAs strRootFolder &" "&ProductName&widgetProductC&".xlsx"
    xlApp.Quit
    Set xlApp = Nothing
    
    
End Function

И второе изменение:

Код:

'Call Export Widgets By Sheet
Function ExportRevenueWidgets(xlDoc,xlSheet, widgetProductX)
	ActiveDocument.GetField("ProductName").select widgetProductX
	CALL ExportWidget(xlDoc,xlSheet,WidgetID, widgetProductX)
	ActiveDocument.GetField("ProductName").Clear	
End Function

После запуска макроса мы получим только 1 Эксель файл и 1 лист с продуктом А:

21.04.2016, 18:04	#19
Aleksandr H. 2 the Nation Glory Старожил Регистрация: 27.05.2014 Сообщений: 3,289	Третьего параметра нету. вам ж написало сверху. Я так понимаю вы отбросили мое предложение по изменению этой функции и продолжаете использовать свою. Ок,gl&hf Кто умер, но не забыт, тот бессмертен. Лао-Цзы.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Макрос рассылка на различные адресаты	KevLev	Помощь студентам	10	19.04.2016 16:29
Макрос для вставки картинки из эксель	КТатьяна	Microsoft Office Excel	0	02.05.2011 12:46
Макрос для экспорта данных в таблицу эксель	scythe	Microsoft Office Excel	2	21.02.2010 22:18
Файлы загрузки	Яр\|/\|\|< (^_^)	Операционные системы общие вопросы	6	03.07.2009 09:55

21.04.2016, 16:21	#17
KevLev Пользователь Регистрация: 19.04.2016 Сообщений: 48	Блин,знак & пропустил