Правильно ли удалены ссылки и освобождена память в программе на Visual basic
Здравствуйте. Не подскажете правильно ли я удаляю ссылки и освобождаю память в
программе? А то на компьютере где выполняется программа начали происходить странные вещи:
при запуске какого либо документа Word он оказывается пуст, а при следующем запуске
напечатанный текст становится виден, excel загружается не сразу, а как бы волнами сверху
вниз и др.
Вот все инструкции в программе, где я создаю и удаляю ссылки и освобождаю память:
Сама программа:
программе? А то на компьютере где выполняется программа начали происходить странные вещи:
при запуске какого либо документа Word он оказывается пуст, а при следующем запуске
напечатанный текст становится виден, excel загружается не сразу, а как бы волнами сверху
вниз и др.
Вот все инструкции в программе, где я создаю и удаляю ссылки и освобождаю память:
Код:
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(put_files)
Set SourceFolder = Nothing
Set FSO = Nothing
Set resul_zapros = MyExcel.ActiveSheet.QueryTables.Add(Connection:= _
connect, _
Destination:=MyExcel.ActiveSheet.Range("A1"))
Set resul_zapros = Nothing
Set nash_list = MyExcel.ActiveWorkbook.Sheets(nazv_list_File) 'Устанавливаем объект nash_list как лист "Основные пок-ли" в
'активной книге
'Для всех остальных листов тоже вводим их объекты, чтобы к ним обращаться
Set list_1 = MyExcel.ActiveWorkbook.Sheets(name_list(1))
Set list_2 = MyExcel.ActiveWorkbook.Sheets(name_list(2))
Set list_3 = MyExcel.ActiveWorkbook.Sheets(name_list(3))
MyExcel.ActiveWorkbook.Close
MyExcel.Quit
Set list_1 = Nothing
Set list_2 = Nothing
Set list_3 = Nothing
Set MyExcel = Nothing
Set nash_list = Nothing
Unload Form1
Set SourceFolder = FSO.GetFolder(put_files)
Set SourceFolder = Nothing
Set FSO = Nothing
Set resul_zapros = MyExcel.ActiveSheet.QueryTables.Add(Connection:= _
connect, _
Destination:=MyExcel.ActiveSheet.Range("A1"))
Set resul_zapros = Nothing
Set nash_list = MyExcel.ActiveWorkbook.Sheets(nazv_list_File) 'Устанавливаем объект nash_list как лист "Основные пок-ли" в
'активной книге
'Для всех остальных листов тоже вводим их объекты, чтобы к ним обращаться
Set list_1 = MyExcel.ActiveWorkbook.Sheets(name_list(1))
Set list_2 = MyExcel.ActiveWorkbook.Sheets(name_list(2))
Set list_3 = MyExcel.ActiveWorkbook.Sheets(name_list(3))
MyExcel.ActiveWorkbook.Close
MyExcel.Quit
Set list_1 = Nothing
Set list_2 = Nothing
Set list_3 = Nothing
Set MyExcel = Nothing
Set nash_list = Nothing
Unload Form1
Сама программа:
Код:
Private Sub Form_Load()
Dim FSO As Object
Dim SourceFolder As Object
Dim SubFolder As Object
Dim FileItem As Object
Dim r As Long
Dim str As String
Dim namefile As String
Dim stroka_name_file As String
Dim chast_name_file As String
Dim MyExcel As Object
Set MyExcel = CreateObject("Excel.Application")
Dim Data_time_system
Dim fs, f, s, stroka
Dim MyTime
Dim MyDate
Dim time_Prover, time_created, timeDate_created
Dim arrPutFile(10) As String
Dim arrNameFile(10) As String
Dim arrTimeCreation(10) As String
Dim arrOnlyHour(10) As String
Dim put_files
Dim Put_files_withNamefile
Dim put_file_s_chert
Dim str_probel
Dim kolvo_files
Dim name_list(10) As String
Dim time_creatZamenadvoet(10) As String
Dim index_TEK_FILE
Dim connect As String 'connection при извлечении из csv
Dim nazv_list_File As String
Dim correct_list_files As String 'Корректное название листа и файла без двоеточий
Const xlDelimited = 1 'xlDelimited это константа и ее надо приравнивать 1 или 2 в зависимости от того нужно извлекать файл с разделителями
'или нет
Const xlTextQualifierDoubleQuote = 1 'xlTextQualifierDoubleQuote это константа и ее надо приравнивать 1 или 2 в зависимости от
'того нужно поставить в качестве разделителя двойные или одинарные кавычки
Dim zapros
Dim i As Integer
Dim Chas_sozd(8) As String
Dim nazv As String
Dim direct_save As String 'Директория для сохранения
Dim direct_and_nameFile As String 'Полный путь сохранения вместе с названием
MyTime = Time
MyDate = Date
i = 1
put_files = "D:papka" ' "D:papka" '"D:REPORT"
put_file_s_chert = put_files & ""
str_probel = ""
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(put_files)
stroka_name_file = "Основные"
For Each FileItem In SourceFolder.Files
namefile = FileItem.Name
chast_name_file = Left(namefile, 8)
If chast_name_file = stroka_name_file Then
arrPutFile(i) = FileItem.Path
Put_files_withNamefile = arrPutFile(i)
'Имя самого файла arrNameFile(i)
arrNameFile(i) = Replace(Put_files_withNamefile, put_file_s_chert, str_probel)
timeDate_created = FileItem.DateCreated
arrTimeCreation(i) = Right(timeDate_created, 8)
time_creatZamenadvoet(i) = Replace(arrTimeCreation(i), ":", "_") 'Замена : во времени на знак подчеркивания
arrOnlyHour(i) = Mid(timeDate_created, 12, 2) 'Время (час) создания файла
i = i + 1
End If
Next FileItem
Set SourceFolder = Nothing
Set FSO = Nothing
kolvo_files = i - 1
MyExcel.Workbooks.Add 'создание новой рабочей книги
MyExcel.Visible = True
For i = 1 To kolvo_files
If arrOnlyHour(i) = "6:" Then
MyExcel.ActiveWorkbook.Sheets("Лист1").Select
name_list(1) = "Основные показатели " & time_creatZamenadvoet(i)
MyExcel.ActiveWorkbook.Sheets("Лист1").Name = name_list(1)
Chas_sozd(1) = arrTimeCreation(i) 'Час создания по порядку
connect = "TEXT;" & arrPutFile(i) 'Строка для запроса connect, которая говорит что это TEXT - текстовый файл и
'путь к файлу
Set resul_zapros = MyExcel.ActiveSheet.QueryTables.Add(Connection:= _
connect, _
Destination:=MyExcel.ActiveSheet.Range("A1"))
With resul_zapros
.Name = name_list(1)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = -535
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Exit For
End If
Next i
Set resul_zapros = Nothing
For i = 1 To kolvo_files
If arrOnlyHour(i) = "8:" Then
MyExcel.ActiveWorkbook.Sheets("Лист2").Select
name_list(2) = "Основные показатели " & time_creatZamenadvoet(i)
MyExcel.ActiveWorkbook.Sheets("Лист2").Name = name_list(2)
Chas_sozd(2) = arrTimeCreation(i) 'Час создания по порядку
connect = "TEXT;" & arrPutFile(i) 'Строка для запроса connect, которая говорит что это TEXT - текстовый файл и
'путь к файлу
Set resul_zapros = MyExcel.ActiveSheet.QueryTables.Add(Connection:= _
connect, _
Destination:=MyExcel.ActiveSheet.Range("A1"))
With resul_zapros
.Name = name_list(1)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = -535
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Exit For
End If
Next i
Set resul_zapros = Nothing
For i = 1 To kolvo_files
If arrOnlyHour(i) = "10" Then
MyExcel.ActiveWorkbook.Sheets("Лист3").Select
name_list(3) = "Основные показатели " & time_creatZamenadvoet(i)
MyExcel.ActiveWorkbook.Sheets("Лист3").Name = name_list(3)
Chas_sozd(3) = arrTimeCreation(i) 'Час создания по порядку
connect = "TEXT;" & arrPutFile(i) 'Строка для запроса connect, которая говорит что это TEXT - текстовый файл и
'путь к файлу
Set resul_zapros = MyExcel.ActiveSheet.QueryTables.Add(Connection:= _
connect, _
Destination:=MyExcel.ActiveSheet.Range("A1"))
With resul_zapros
.Name = name_list(1)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = -535
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Exit For
End If
Next i
Set resul_zapros = Nothing
'Удалить файлы csv по заданному пути
' For i = 1 To kolvo_files
' Kill (arrPutFile(i))
' Next i
MyDate = Replace(MyDate, ".", "_")
nazv_list_File = "Основные показатели " & MyDate 'Название для листа и имени файла с временем создания
MyExcel.ActiveWorkbook.Sheets(name_list(3)).Select 'Выбираем 3-ий лист
MyExcel.ActiveWorkbook.Sheets.Add 'Добавляем новый лист
MyExcel.ActiveWorkbook.Sheets("Лист4").Select 'Выбираем созданный лист
MyExcel.ActiveWorkbook.Sheets("Лист4").Move After:=MyExcel.ActiveWorkbook.Sheets(name_list(3)) 'Передвигаем созданный лист
'в конец через все листы
MyExcel.ActiveWorkbook.Sheets("Лист4").Name = nazv_list_File 'Именуем новый лист названием и временем создания
Set nash_list = MyExcel.ActiveWorkbook.Sheets(nazv_list_File) 'Устанавливаем объект nash_list как лист "Основные пок-ли" в
'активной книге
'Для всех остальных листов тоже вводим их объекты, чтобы к ним обращаться
Set list_1 = MyExcel.ActiveWorkbook.Sheets(name_list(1))
Set list_2 = MyExcel.ActiveWorkbook.Sheets(name_list(2))
Set list_3 = MyExcel.ActiveWorkbook.Sheets(name_list(3))
'СОЗДАЕМ ШАБЛОН ЛИСТА КУДА БУДЕМ ПОМЕЩАТЬ ЗНАЧЕНИЯ С ДРУГИХ ЛИСТОВ
With nash_list
.Columns("A:A").ColumnWidth = 12
With .Range("A1:A2") '.Selection
.HorizontalAlignment = -4108 'Выравнивание по горизонтали в ячейке
.VerticalAlignment = -4117 'Выравнивание по вертикали в объединенной ячейке
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = True 'Здесь атрибут .mergecells = true - объединить ячейки
.FormulaR1C1 = "Показатель"
End With
.Columns("B:B").ColumnWidth = 12
With .Range("B1:B2") '.Selection
.HorizontalAlignment = -4108 'Выравнивание по горизонтали в ячейке
.VerticalAlignment = -4117 'Выравнивание по вертикали в объединенной ячейке
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = True 'Здесь атрибут .mergecells = true - объединить ячейки
.FormulaR1C1 = "Единица измерения"
End With
With .Range("C1:D1")
.HorizontalAlignment = -4108
.VerticalAlignment = -4117
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = True
.FormulaR1C1 = "Замер в " & Chas_sozd(1)
End With
With .Range("E1:F1")
.HorizontalAlignment = -4108
.VerticalAlignment = -4117
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = True
.FormulaR1C1 = "Замер в " & Chas_sozd(2)
End With
With .Range("C2")
.HorizontalAlignment = -4108
.VerticalAlignment = -4117
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = False
.FormulaR1C1 = "Норматив"
End With
With .Range("D2")
.HorizontalAlignment = -4108
.VerticalAlignment = -4117
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = False
.FormulaR1C1 = "Факт"
End With
With .Range("E2")
.HorizontalAlignment = -4108
.VerticalAlignment = -4117
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = False
.FormulaR1C1 = "Норматив"
End With
With .Range("F2")
.HorizontalAlignment = -4108
.VerticalAlignment = -4117
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = False
.FormulaR1C1 = "Факт"
End With
End With
'Копируем данные с 3х листов
'в наш лист
'Для 1-го листа
For i = 3 To 5 'Для строк в копируемый лист
j = i + 8
nash_list.Range("A1:D100").Cells(i, 4) = list_1.Range("A1:D100").Cells(j, 4)
'[Диап_Наш_лист].Cells(i, 4) = [Диапазон_ЛИСТ1].Cells(j, 4)
Next i
'Для 2-го листа
For i = 3 To 5 'Для строк в копируемый лист
j = i + 8
nash_list.Range("A1:D100").Cells(i, 6) = list_2.Range("A1:D100").Cells(j, 4)
'[Диап_Наш_лист].Cells(i, 4) = [Диапазон_ЛИСТ1].Cells(j, 4)
Next i
'Удаляем листы кроме скомпанованного листа
With MyExcel.ActiveWorkbook
For i = 1 To 3
MyExcel.DisplayAlerts = False
.Sheets(name_list(i)).Delete
MyExcel.DisplayAlerts = True
Next i
End With
direct_save = "D:install games"
direct_and_nameFile = direct_save & "" & nazv_list_File & ".xls"
'Обязательно сохранять файлы ТОЛЬКО В РАЗНЫЕ ДНИ ИНАЧЕ ИМЯ БУДЕТ СОВПАДАТЬ НАПРИМЕР В 23:50:00 КАЖДЖЫЙ ДЕНЬ
ChDir direct_save 'Здесь нужно прописать директорию куда будем сохранять данный файл
MyExcel.ActiveWorkbook.SaveAs FileName:=direct_and_nameFile, FileFormat:= _
-4143, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
MyExcel.ActiveWorkbook.Close
MyExcel.Quit
Set list_1 = Nothing
Set list_2 = Nothing
Set list_3 = Nothing
Set MyExcel = Nothing
Set nash_list = Nothing
Unload Form1
End Sub
Dim FSO As Object
Dim SourceFolder As Object
Dim SubFolder As Object
Dim FileItem As Object
Dim r As Long
Dim str As String
Dim namefile As String
Dim stroka_name_file As String
Dim chast_name_file As String
Dim MyExcel As Object
Set MyExcel = CreateObject("Excel.Application")
Dim Data_time_system
Dim fs, f, s, stroka
Dim MyTime
Dim MyDate
Dim time_Prover, time_created, timeDate_created
Dim arrPutFile(10) As String
Dim arrNameFile(10) As String
Dim arrTimeCreation(10) As String
Dim arrOnlyHour(10) As String
Dim put_files
Dim Put_files_withNamefile
Dim put_file_s_chert
Dim str_probel
Dim kolvo_files
Dim name_list(10) As String
Dim time_creatZamenadvoet(10) As String
Dim index_TEK_FILE
Dim connect As String 'connection при извлечении из csv
Dim nazv_list_File As String
Dim correct_list_files As String 'Корректное название листа и файла без двоеточий
Const xlDelimited = 1 'xlDelimited это константа и ее надо приравнивать 1 или 2 в зависимости от того нужно извлекать файл с разделителями
'или нет
Const xlTextQualifierDoubleQuote = 1 'xlTextQualifierDoubleQuote это константа и ее надо приравнивать 1 или 2 в зависимости от
'того нужно поставить в качестве разделителя двойные или одинарные кавычки
Dim zapros
Dim i As Integer
Dim Chas_sozd(8) As String
Dim nazv As String
Dim direct_save As String 'Директория для сохранения
Dim direct_and_nameFile As String 'Полный путь сохранения вместе с названием
MyTime = Time
MyDate = Date
i = 1
put_files = "D:papka" ' "D:papka" '"D:REPORT"
put_file_s_chert = put_files & ""
str_probel = ""
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(put_files)
stroka_name_file = "Основные"
For Each FileItem In SourceFolder.Files
namefile = FileItem.Name
chast_name_file = Left(namefile, 8)
If chast_name_file = stroka_name_file Then
arrPutFile(i) = FileItem.Path
Put_files_withNamefile = arrPutFile(i)
'Имя самого файла arrNameFile(i)
arrNameFile(i) = Replace(Put_files_withNamefile, put_file_s_chert, str_probel)
timeDate_created = FileItem.DateCreated
arrTimeCreation(i) = Right(timeDate_created, 8)
time_creatZamenadvoet(i) = Replace(arrTimeCreation(i), ":", "_") 'Замена : во времени на знак подчеркивания
arrOnlyHour(i) = Mid(timeDate_created, 12, 2) 'Время (час) создания файла
i = i + 1
End If
Next FileItem
Set SourceFolder = Nothing
Set FSO = Nothing
kolvo_files = i - 1
MyExcel.Workbooks.Add 'создание новой рабочей книги
MyExcel.Visible = True
For i = 1 To kolvo_files
If arrOnlyHour(i) = "6:" Then
MyExcel.ActiveWorkbook.Sheets("Лист1").Select
name_list(1) = "Основные показатели " & time_creatZamenadvoet(i)
MyExcel.ActiveWorkbook.Sheets("Лист1").Name = name_list(1)
Chas_sozd(1) = arrTimeCreation(i) 'Час создания по порядку
connect = "TEXT;" & arrPutFile(i) 'Строка для запроса connect, которая говорит что это TEXT - текстовый файл и
'путь к файлу
Set resul_zapros = MyExcel.ActiveSheet.QueryTables.Add(Connection:= _
connect, _
Destination:=MyExcel.ActiveSheet.Range("A1"))
With resul_zapros
.Name = name_list(1)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = -535
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Exit For
End If
Next i
Set resul_zapros = Nothing
For i = 1 To kolvo_files
If arrOnlyHour(i) = "8:" Then
MyExcel.ActiveWorkbook.Sheets("Лист2").Select
name_list(2) = "Основные показатели " & time_creatZamenadvoet(i)
MyExcel.ActiveWorkbook.Sheets("Лист2").Name = name_list(2)
Chas_sozd(2) = arrTimeCreation(i) 'Час создания по порядку
connect = "TEXT;" & arrPutFile(i) 'Строка для запроса connect, которая говорит что это TEXT - текстовый файл и
'путь к файлу
Set resul_zapros = MyExcel.ActiveSheet.QueryTables.Add(Connection:= _
connect, _
Destination:=MyExcel.ActiveSheet.Range("A1"))
With resul_zapros
.Name = name_list(1)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = -535
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Exit For
End If
Next i
Set resul_zapros = Nothing
For i = 1 To kolvo_files
If arrOnlyHour(i) = "10" Then
MyExcel.ActiveWorkbook.Sheets("Лист3").Select
name_list(3) = "Основные показатели " & time_creatZamenadvoet(i)
MyExcel.ActiveWorkbook.Sheets("Лист3").Name = name_list(3)
Chas_sozd(3) = arrTimeCreation(i) 'Час создания по порядку
connect = "TEXT;" & arrPutFile(i) 'Строка для запроса connect, которая говорит что это TEXT - текстовый файл и
'путь к файлу
Set resul_zapros = MyExcel.ActiveSheet.QueryTables.Add(Connection:= _
connect, _
Destination:=MyExcel.ActiveSheet.Range("A1"))
With resul_zapros
.Name = name_list(1)
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = -535
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Exit For
End If
Next i
Set resul_zapros = Nothing
'Удалить файлы csv по заданному пути
' For i = 1 To kolvo_files
' Kill (arrPutFile(i))
' Next i
MyDate = Replace(MyDate, ".", "_")
nazv_list_File = "Основные показатели " & MyDate 'Название для листа и имени файла с временем создания
MyExcel.ActiveWorkbook.Sheets(name_list(3)).Select 'Выбираем 3-ий лист
MyExcel.ActiveWorkbook.Sheets.Add 'Добавляем новый лист
MyExcel.ActiveWorkbook.Sheets("Лист4").Select 'Выбираем созданный лист
MyExcel.ActiveWorkbook.Sheets("Лист4").Move After:=MyExcel.ActiveWorkbook.Sheets(name_list(3)) 'Передвигаем созданный лист
'в конец через все листы
MyExcel.ActiveWorkbook.Sheets("Лист4").Name = nazv_list_File 'Именуем новый лист названием и временем создания
Set nash_list = MyExcel.ActiveWorkbook.Sheets(nazv_list_File) 'Устанавливаем объект nash_list как лист "Основные пок-ли" в
'активной книге
'Для всех остальных листов тоже вводим их объекты, чтобы к ним обращаться
Set list_1 = MyExcel.ActiveWorkbook.Sheets(name_list(1))
Set list_2 = MyExcel.ActiveWorkbook.Sheets(name_list(2))
Set list_3 = MyExcel.ActiveWorkbook.Sheets(name_list(3))
'СОЗДАЕМ ШАБЛОН ЛИСТА КУДА БУДЕМ ПОМЕЩАТЬ ЗНАЧЕНИЯ С ДРУГИХ ЛИСТОВ
With nash_list
.Columns("A:A").ColumnWidth = 12
With .Range("A1:A2") '.Selection
.HorizontalAlignment = -4108 'Выравнивание по горизонтали в ячейке
.VerticalAlignment = -4117 'Выравнивание по вертикали в объединенной ячейке
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = True 'Здесь атрибут .mergecells = true - объединить ячейки
.FormulaR1C1 = "Показатель"
End With
.Columns("B:B").ColumnWidth = 12
With .Range("B1:B2") '.Selection
.HorizontalAlignment = -4108 'Выравнивание по горизонтали в ячейке
.VerticalAlignment = -4117 'Выравнивание по вертикали в объединенной ячейке
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = True 'Здесь атрибут .mergecells = true - объединить ячейки
.FormulaR1C1 = "Единица измерения"
End With
With .Range("C1:D1")
.HorizontalAlignment = -4108
.VerticalAlignment = -4117
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = True
.FormulaR1C1 = "Замер в " & Chas_sozd(1)
End With
With .Range("E1:F1")
.HorizontalAlignment = -4108
.VerticalAlignment = -4117
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = True
.FormulaR1C1 = "Замер в " & Chas_sozd(2)
End With
With .Range("C2")
.HorizontalAlignment = -4108
.VerticalAlignment = -4117
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = False
.FormulaR1C1 = "Норматив"
End With
With .Range("D2")
.HorizontalAlignment = -4108
.VerticalAlignment = -4117
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = False
.FormulaR1C1 = "Факт"
End With
With .Range("E2")
.HorizontalAlignment = -4108
.VerticalAlignment = -4117
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = False
.FormulaR1C1 = "Норматив"
End With
With .Range("F2")
.HorizontalAlignment = -4108
.VerticalAlignment = -4117
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = False
.FormulaR1C1 = "Факт"
End With
End With
'Копируем данные с 3х листов
'в наш лист
'Для 1-го листа
For i = 3 To 5 'Для строк в копируемый лист
j = i + 8
nash_list.Range("A1:D100").Cells(i, 4) = list_1.Range("A1:D100").Cells(j, 4)
'[Диап_Наш_лист].Cells(i, 4) = [Диапазон_ЛИСТ1].Cells(j, 4)
Next i
'Для 2-го листа
For i = 3 To 5 'Для строк в копируемый лист
j = i + 8
nash_list.Range("A1:D100").Cells(i, 6) = list_2.Range("A1:D100").Cells(j, 4)
'[Диап_Наш_лист].Cells(i, 4) = [Диапазон_ЛИСТ1].Cells(j, 4)
Next i
'Удаляем листы кроме скомпанованного листа
With MyExcel.ActiveWorkbook
For i = 1 To 3
MyExcel.DisplayAlerts = False
.Sheets(name_list(i)).Delete
MyExcel.DisplayAlerts = True
Next i
End With
direct_save = "D:install games"
direct_and_nameFile = direct_save & "" & nazv_list_File & ".xls"
'Обязательно сохранять файлы ТОЛЬКО В РАЗНЫЕ ДНИ ИНАЧЕ ИМЯ БУДЕТ СОВПАДАТЬ НАПРИМЕР В 23:50:00 КАЖДЖЫЙ ДЕНЬ
ChDir direct_save 'Здесь нужно прописать директорию куда будем сохранять данный файл
MyExcel.ActiveWorkbook.SaveAs FileName:=direct_and_nameFile, FileFormat:= _
-4143, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
MyExcel.ActiveWorkbook.Close
MyExcel.Quit
Set list_1 = Nothing
Set list_2 = Nothing
Set list_3 = Nothing
Set MyExcel = Nothing
Set nash_list = Nothing
Unload Form1
End Sub
- Перед вопросом пишите: Среда разработки... Среда исполнения... от OldProcessor, 25 октября 2016 года