GetPayments = (2 * (Payment2 - Sum / N)) / (N - 1)
End Function
ThisWorkbook.ActiveSheet.Cells.WrapText = False 'снимаем перенос строк
'нерезультативных закрасим красным
If Sp.Cells(new_mpl + 4, m + 1) < 1 Then Sp.Cells(new_mpl + 4, m + 1).Font.Color = -16776961
&chr(13) - перенос на следующую строку (если в vbe пишем)
Option Compare text - пишем под Option Explicit, если не нужно учитывать регистр для select case и т.д.
Option Base 1 - массивы будут начинаться не с 0, а с 1.
Уникальные занчения:
Sub uniquetiems()
dim col as collection
col.addunique array([f1].value, [a1:a2].value,....)
range("j1").resize(col.count).value = col.toarray
end sub
Работа с кодом:
Подсказка - Выделяем функцию - правая кнопка - quickInfo
F2 - библиотека
vb... - встроенные константы VB, xl... - встроенные константы Excel.
Окно Immediate - иполняет написанное выражение, например, cells.clear, или ?2+2
Макрос можно записывать и с относительными ссылками, VBA все поймет.
Ячейки формируются сначала слева-направо, потом сверху-вниз.
Объект Range.
Dim rng As Range
With Range("d2:g10")
.value = 1
.interior.color = vbGreen
end with
Range("d2:g10") = [d2:g10], можно и [Лист1].tab.color = vbred (цвет вкладки меням)
set rng = selection
rng.colums(1) - первая колонка выделенного диапазона (так же rows)
'форма поверх всех окон
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) As Long
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOPMOST = -1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Sub UserForm_Activate()
Dim hWnd As Long
hWnd = FindWindow(vbNullString, Me.Caption)
Call SetWindowPos(hWnd, HWND_TOPMOST, 100, 0, 100, 0, WP_NOMOVE Or SWP_NOSIZE)
'*******Форма в нормальное положение**************
' Call SetWindowPos(hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
'**********************************************
End Sub
'Вставляем на лист, где будут изменения. При изменении в ячейке запускать макрос.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("B1")) Is Nothing Then
Call Этот_макрос_запустится
End If
End Sub
'Даем диапазон и переменную, получаем уникальные значения в массиве
Dim b
Sub Extract_Unique(ByVal rng As Range, ByRef b As Variant)
Dim vItem, avArr, li As Long
ReDim avArr(1 To 1)
With New Collection
On Error Resume Next
For Each vItem In rng.Value
'Cells(Rows.Count, 1).End(xlUp) – определяет последнюю заполненную ячейку в столбце А
.Add vItem, CStr(vItem)
If Err = 0 Then
li = li + 1
ReDim Preserve avArr(1 To li)
avArr(li) = vItem
Else: Err.Clear
End If
Next
End With
b = avArr
End Sub
'при работе с фильтром
ActiveSheet.AutoFilterMode -- даст ответ о наличии автофильтра на листе (true/false)
ActiveSheet.AutoFilter.FilterMode -- true - если что-то отфильтровано, false - если фильтрация не установлена.
There is a Filters collection associated with the AutoFilter object that holds a Filter object for each field in the AutoFilter
Sub Main() With ActiveSheet.ListObjects(1) If .ShowAutoFilter Then With .AutoFilter.Filters(2) If .On Then MsgBox .Criteria1 End If End With End If End With End Sub 'выключили, потом включили With Application calcmode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With With Application .ScreenUpdating = True .Calculation = calcmode End With
ActiveWindow.DisplayHorizontalScrollBar = True ' показать горизонтальный скроллбар
Worksheets(1).ScrollArea = Cells.Address ' разрешить прокрутку по всему листу (ограничеваем так "A1:B10" )
QueryTable: Selection.QueryTable.PreserveColumnInfo = True (.destination (column,row) - куда вставлять)
Sub GroupSelection()
'группируем строки если встретили изменение
l_row = Selection.Row
i_col = Selection.Column
s_name = Cells(l_row, i_col)
For Each cell In Selection
If Cells(cell.Row + 1, i_col) <> s_name Then
Rows(l_row & ":" & cell.Row - 1).Group
l_row = cell.Row + 1
s_name = Cells(cell.Row + 1, i_col)
End If
Next
End Sub
Sub UnGroupSelection()
'расгруппировываем выделенные строки
Selection.Rows.EntireRow.Ungroup
End Sub
Function Open_Folder_by_Path(Path$)
'Открыть папку по указанному пути
CreateObject("Shell.Application").Explore (Path)
End Function
Function Open_Folder_by_Path_in_Cell(cell As Range)
'Открыть папку по указанному пути в диапазоне
CreateObject("Shell.Application").Explore (cell.Text)
End Function
Function IsArrayAllocated(Arr As Variant) As Boolean
'проверка заполнения массива. false - массив пуст
On Error Resume Next
IsArrayAllocated = IsArray(Arr) And _
Not IsError(LBound(Arr, 1)) And _
LBound(Arr, 1) <= UBound(Arr, 1)
End Function
Application.Goto Cells(491, СтолбецNum), 1Application.SendKeys "^{BS}" 'ctrl + backspace'Нарезаем файлы по уникльным значениям в указанном диапазоне
Sub НарезатьФайлы()
T = Timer
Application.DisplayAlerts = False
Dim GeneralFilePick As FileDialog
Dim Col_n As Collection
Set GeneralFilePick = Application.FileDialog(msoFileDialogFilePicker)
With GeneralFilePick
' .Filters.Add "Excel files", "*.xls*;*.xla*;*.xlsx*", 1
.Title = "Выберите, пожалуйста, файл для нарезки (основной файл с данными)"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path
.Show
End With
Workbooks.Open Filename:=GeneralFilePick.SelectedItems(1) 'открываем
Set GeneralFile = ActiveWorkbook
GeneralFileName = ActiveWorkbook.Name
GeneralFilePath = ActiveWorkbook.Path
GenFullName = ActiveWorkbook.FullName
'удаляем лишнее
On Error Resume Next
Set SelectedRange = Application.InputBox("Выберите дипазон для удаления, который не будет содержаться в нарезанных файлах. " & _
"Через CTRL+ можно несколько диапазонов выбрать. Нажмите <Отмена>, если удаления не требуются.", "Запрос данных", "", Type:=8)
RangeForClearing = SelectedRange.Address
RangeForClearingList = SelectedRange.Worksheet.Name
GeneralFile.Sheets(RangeForClearingList).Activate
If ThisWorkbook.Sheets(1).Cells(4, 8) Then GeneralFile.Sheets(RangeForClearingList).Range(RangeForClearing).ClearContents
If Not ThisWorkbook.Sheets(1).Cells(4, 8) Then GeneralFile.Sheets(RangeForClearingList).Range(RangeForClearing).Clear 'ClearContents - если только значения удалить
Err.Clear
'выбираем диапазон для фильтрации (нарезки)
Set SelectedRange = Application.InputBox("Выберите дипазон для фильтрации (ФИО, Подразделения и т.п.), включая заголовок. <Отмена> закроет программу.", "Запрос данных", "", Type:=8)
If Err <> 0 Then GeneralFile.Saved = True: GeneralFile.Close: Exit Sub
filterrange = SelectedRange.Address
filterrangelist = SelectedRange.Worksheet.Name
HeaderCellrow = SelectedRange.Cells.Row
HeaderCellColumn = SelectedRange.Cells.Column
Set GeneralFolderPick = Application.FileDialog(msoFileDialogFolderPicker)
With GeneralFolderPick
' .Filters.Add "Excel files", "*.xls*;*.xla*;*.xlsx*", 1
.Title = "Выберите папку для нарезки (куда складывать файлы)"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path
.Show
End With
GeneralFolder = GeneralFolderPick.SelectedItems(1)
GenFileFormat = GeneralFile.FileFormat
Application.ScreenUpdating = False
'начинаем фильтацию
If GeneralFile.Sheets(filterrangelist).AutoFilterMode Then GeneralFile.Sheets(filterrangelist).Cells.AutoFilter
Set Col_n = New Collection
lasti = Range(filterrange).Count
rangerows = HeaderCellrow + 1 & ":" & HeaderCellrow + lasti - 1
For i = 1 To lasti - 1
curfilename = GeneralFile.Sheets(filterrangelist).Cells(HeaderCellrow + i, HeaderCellColumn)
On Error Resume Next
Col_n.Add curfilename, curfilename
If Err = 0 Then
If ThisWorkbook.Sheets(1).Cells(4, 8) Then GeneralFile.Sheets(RangeForClearingList).Range(RangeForClearing).ClearContents
If Not ThisWorkbook.Sheets(1).Cells(4, 8) Then GeneralFile.Sheets(RangeForClearingList).Range(RangeForClearing).Clear
If GeneralFile.Sheets(filterrangelist).AutoFilterMode Then GeneralFile.Sheets(filterrangelist).Cells.AutoFilter
GeneralFile.Sheets(filterrangelist).Range(filterrange).AutoFilter field:=1, Criteria1:="<>" & curfilename
GeneralFile.Sheets(filterrangelist).Rows(rangerows).SpecialCells(xlVisible).Delete
GeneralFile.Sheets(filterrangelist).AutoFilterMode = False
Application.CutCopyMode = False
ActiveWindow.ScrollRow = 1
If ThisWorkbook.Sheets(1).Range("H6") Then
GeneralFile.SaveAs Filename:=GeneralFolder & "\" & Replace_symbols(curfilename, ThisWorkbook.Sheets(1).Range("L6")) _
& ".xlsx", FileFormat:=xlOpenXMLWorkbook
Else
GeneralFile.SaveAs Filename:=GeneralFolder & "\" & curfilename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
End If
GeneralFile.Close
Workbooks.Open (GenFullName)
Set GeneralFile = ActiveWorkbook
Else
Err.Clear
End If
Next i
If ThisWorkbook.Sheets(1).Range("h2") = True Then
GeneralFile.Saved = True
GeneralFile.Close
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Execution Time: " & Format(Fix(Timer - T) / 86400, "h:mm:ss") & Format(Timer - T - Fix(Timer - T), ".00000")
End Sub
'функция замены запрещенных символов для сохранения файла
Function Replace_symbols(ByVal txt As String, Optional ByVal replaceTo As String) As String
If replaceTo = Empty Then replaceTo = ""
repTo = replaceTo
St$ = "\/:*?""<>|"
For i% = 1 To Len(St$)
txt = Replace(txt, Mid(St$, i, 1), repTo)
Next
Replace_symbols = txt
End Function
'Нарезаем файлы по уникльным значениям в указанном диапазоне на 2-х листах
Sub Нарезать_Файлы_По_Подразделениям()
T = Timer
Application.DisplayAlerts = False
Dim GeneralFilePick As FileDialog
Dim Col_n As Collection
Set GeneralFilePick = Application.FileDialog(msoFileDialogFilePicker)
With GeneralFilePick
' .Filters.Add "Excel files", "*.xls*;*.xla*;*.xlsx*", 1
.Title = "Выберите, пожалуйста, файл для нарезки (основной файл с данными)"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path
.Show
End With
If GeneralFilePick.SelectedItems.Count <> 1 Then Exit Sub
Workbooks.Open Filename:=GeneralFilePick.SelectedItems(1) 'открываем
Set GeneralFile = ActiveWorkbook
GeneralFileName = ActiveWorkbook.Name
GeneralFilePath = ActiveWorkbook.Path
GenFullName = ActiveWorkbook.FullName
'удаляем лишнее
On Error Resume Next
Set SelectedRange = Application.InputBox("Выберите дипазон для удаления, который не будет содержаться в нарезанных файлах. " & _
"Через CTRL+ можно несколько диапазонов выбрать. Нажмите <Отмена>, если удаления не требуются.", "Запрос данных", "", Type:=8)
RangeForClearing = SelectedRange.Address
RangeForClearingList = SelectedRange.Worksheet.Name
GeneralFile.Sheets(RangeForClearingList).Activate
If ThisWorkbook.Sheets(1).Cells(4, 8) Then GeneralFile.Sheets(RangeForClearingList).Range(RangeForClearing).ClearContents
If Not ThisWorkbook.Sheets(1).Cells(4, 8) Then GeneralFile.Sheets(RangeForClearingList).Range(RangeForClearing).Clear 'ClearContents - если только значения удалить
Err.Clear
'выбираем диапазон для фильтрации (нарезки)
Set SelectedRange = Application.InputBox("Выберите диапазон для фильтрации (ФИО, Подразделения и т.п.), включая заголовок. <Отмена> закроет программу.", "Запрос данных", "", Type:=8)
If Err <> 0 Then GeneralFile.Saved = True: GeneralFile.Close: Exit Sub
filterrange = SelectedRange.Address
filterrangelist = SelectedRange.Worksheet.Name
HeaderCellrow = SelectedRange.Cells.Row
HeaderCellColumn = SelectedRange.Cells.Column
'выбираем ВТОРОЙ диапазон для фильтрации (скажем, регионы)
Set SelectedRange2 = Application.InputBox("Выберите ВТОРОЙ диапазон для фильтрации (ФИО, Подразделения и т.п.), включая заголовок. <Отмена> закроет программу.", "Запрос данных", "", Type:=8)
If Err <> 0 Then GeneralFile.Saved = True: GeneralFile.Close: Exit Sub
filterrange2 = SelectedRange2.Address
filterrangelist2 = SelectedRange2.Worksheet.Name
HeaderCellrow2 = SelectedRange2.Cells.Row
HeaderCellColumn2 = SelectedRange2.Cells.Column
''выбираем ТРЕТИЙ диапазон для фильтрации (скажем, регионы)
'Set SelectedRange3 = Application.InputBox("Выберите ТРЕТИЙ диапазон для фильтрации (ФИО, Подразделения и т.п.), включая заголовок. <Отмена> закроет программу.", "Запрос данных", "", Type:=8)
'If Err <> 0 Then GeneralFile.Saved = True: GeneralFile.Close: Exit Sub
'filterrange3 = SelectedRange3.Address
'filterrangelist3 = SelectedRange3.Worksheet.Name
'HeaderCellrow3 = SelectedRange3.Cells.Row
'HeaderCellColumn3 = SelectedRange3.Cells.Column
Set GeneralFolderPick = Application.FileDialog(msoFileDialogFolderPicker)
With GeneralFolderPick
' .Filters.Add "Excel files", "*.xls*;*.xla*;*.xlsx*", 1
.Title = "Выберите папку для нарезки (куда складывать файлы)"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path
.Show
End With
GeneralFolder = GeneralFolderPick.SelectedItems(1)
GenFileFormat = GeneralFile.FileFormat
Application.ScreenUpdating = False
'начинаем фильтацию
If GeneralFile.Sheets(filterrangelist).AutoFilterMode Then GeneralFile.Sheets(filterrangelist).Cells.AutoFilter 'если стоит автофильтр, то сбрасываем
Set Col_n = New Collection
lasti = Range(filterrange).Count
lasti2 = Range(filterrange2).Count
'lasti3 = Range(filterrange3).Count
rangerows = HeaderCellrow + 1 & ":" & HeaderCellrow + lasti - 1 'наш диапазон строк
rangerows2 = HeaderCellrow2 + 1 & ":" & HeaderCellrow2 + lasti2 - 1
rangerows3 = HeaderCellrow3 + 1 & ":" & HeaderCellrow3 + lasti3 - 1
For i = 1 To lasti - 1
curfilename = GeneralFile.Sheets(filterrangelist).Cells(HeaderCellrow + i, HeaderCellColumn)
On Error Resume Next
Col_n.Add curfilename, curfilename
If Err = 0 Then
If ThisWorkbook.Sheets(1).Cells(4, 8) Then GeneralFile.Sheets(RangeForClearingList).Range(RangeForClearing).ClearContents 'удаляем лишнее, если галка
If Not ThisWorkbook.Sheets(1).Cells(4, 8) Then GeneralFile.Sheets(RangeForClearingList).Range(RangeForClearing).Clear
If GeneralFile.Sheets(filterrangelist).AutoFilterMode Then GeneralFile.Sheets(filterrangelist).Cells.AutoFilter 'если стоит автофильтр, то сбрасываем
'фильтруем 1-й диапазон
GeneralFile.Sheets(filterrangelist).Activate
GeneralFile.Sheets(filterrangelist).Range(filterrange).AutoFilter field:=1, Criteria1:="<>" & curfilename 'фильтруем наше подразделение
GeneralFile.Sheets(filterrangelist).Rows(rangerows).SpecialCells(xlVisible).Delete 'удаляем видимые строки
GeneralFile.Sheets(filterrangelist).AutoFilterMode = False ' снимаем фильтр
GeneralFile.Sheets(filterrangelist).Rows(HeaderCellrow).AutoFilter
Application.CutCopyMode = False
ActiveWindow.ScrollRow = 1 'перелистнули в начало
'фильтруем 2-й диапазон
GeneralFile.Sheets(filterrangelist2).Activate
If GeneralFile.Sheets(filterrangelist2).AutoFilterMode Then GeneralFile.Sheets(filterrangelist2).Cells.AutoFilter
GeneralFile.Sheets(filterrangelist2).Range(filterrange2).AutoFilter field:=1, Criteria1:="<>" & curfilename
GeneralFile.Sheets(filterrangelist2).Rows(rangerows2).SpecialCells(xlVisible).Delete
GeneralFile.Sheets(filterrangelist2).AutoFilterMode = False
GeneralFile.Sheets(filterrangelist2).Rows(HeaderCellrow2).AutoFilter
Application.CutCopyMode = False
ActiveWindow.ScrollRow = 1
' 'фильтруем 3-й диапазон
' GeneralFile.Sheets(filterrangelist3).Activate
' If GeneralFile.Sheets(filterrangelist3).AutoFilterMode Then GeneralFile.Sheets(filterrangelist3).Cells.AutoFilter
' GeneralFile.Sheets(filterrangelist3).Range(filterrange3).AutoFilter field:=1, Criteria1:="<>" & curfilename
' GeneralFile.Sheets(filterrangelist3).Rows(rangerows3).SpecialCells(xlVisible).Delete
' GeneralFile.Sheets(filterrangelist3).AutoFilterMode = False
' Application.CutCopyMode = False
' ActiveWindow.ScrollRow = 1
If ThisWorkbook.Sheets(1).Range("H6") Then 'заменять недопустимые символы
GeneralFile.SaveAs Filename:=GeneralFolder & "\" & Replace_symbols(curfilename, ThisWorkbook.Sheets(1).Range("L6")) _
& ".xlsx", FileFormat:=xlOpenXMLWorkbook
Else
GeneralFile.SaveAs Filename:=GeneralFolder & "\" & curfilename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
End If
GeneralFile.Close
Workbooks.Open Filename:=GenFullName, UpdateLinks:=True
Set GeneralFile = ActiveWorkbook
'удаляем разрезку по регионам, подразделениям она не нужна
GeneralFile.Worksheets("Подразделения").Rows("2:16").Delete
Else
Err.Clear
End If
Next i
If ThisWorkbook.Sheets(1).Range("h2") = True Then
GeneralFile.Saved = True
GeneralFile.Close
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Execution Time: " & Format(Fix(Timer - T) / 86400, "h:mm:ss") & Format(Timer - T - Fix(Timer - T), ".00000")
End Sub
По SQL:
% - любые значения, любой длины.
'a' + 'b' = ab - так можно сливать столбцы воедино
Sub Переименовка_выбранных_файлов()
Dim obj_file As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Application.DisplayAlerts = False
ReDim arr_file_names(1 To 1) As String
'Смена текущего каталога:
ChDir ThisWorkbook.Path
avFiles = Application.GetOpenFilename _
("Excel files(*.xl*),*.xl*", 2, "Выбрать Excel файлы", , True) ',Text files(*.txt),*.txt
If IsArray(avFiles) = False Then Exit Sub
int_File_Number = UBound(avFiles) 'количество выделенных файлов
'wbreport = "Отчет по заявкам 30.11.16.xlsx" 'тут у меня планы вставлены
'Workbooks(wbreport).Worksheets("Отчет").Outline.ShowLevels , 3
'Workbooks(wbreport).Worksheets("Отчет").Range("CH5:Ci63").Copy
'Application.CutCopyMode = False
For i = 1 To int_File_Number
ReDim Preserve arr_file_names(1 To i)
arr_file_names(i) = Dir(avFiles(i))
Set obj_file = objFSO.getfile(avFiles(i))
obj_file.Name = ThisWorkbook.Sheets("Лист1").Range("H15") & obj_file.Name
Next
Application.DisplayAlerts = True
End Sub
Sub Замена_имени_выбранных_файлов()
Dim obj_file As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Application.DisplayAlerts = False
ReDim arr_file_names(1 To 1) As String
avFiles = Application.GetOpenFilename _
("Excel files(*.xl*),*.xl*", 2, "Выбрать Excel файлы", , True) ',Text files(*.txt),*.txt
If IsArray(avFiles) = False Then Exit Sub
int_File_Number = UBound(avFiles) 'количество выделенных файлов
'wbreport = "Отчет по заявкам 30.11.16.xlsx" 'тут у меня планы вставлены
'Workbooks(wbreport).Worksheets("Отчет").Outline.ShowLevels , 3
'Workbooks(wbreport).Worksheets("Отчет").Range("CH5:Ci63").Copy
'Application.CutCopyMode = False
For i = 1 To int_File_Number
ReDim Preserve arr_file_names(1 To i)
arr_file_names(i) = Dir(avFiles(i))
Set obj_file = objFSO.getfile(avFiles(i))
obj_file.Name = Replace(obj_file.Name, ThisWorkbook.Sheets("Лист1").Range("H20"), ThisWorkbook.Sheets("Лист1").Range("H22"))
Next
Application.DisplayAlerts = True
End Sub
Sub Unlock_Excel_WorksheetNoMessage()
t = Timer
If UnlockSheet(ActiveSheet) Then
'MsgBox "Защита снята. Потребовалось времени: " & Format(Timer - t, "0.0 сек.")
Else
'MsgBox "Не удалось снять защиту листа", vbCritical
End If
End Sub
Function UnlockSheet(ByRef sh As Worksheet) As Boolean
'снятие пароля с активного листа
Dim i%, j%, k%, l%, m%, n As Long, i1%, i2%, i3%, i4%, i5%, i6%, txt$
On Error Resume Next
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66
txt$ = Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6)
For n = 32 To 126
sh.Unprotect txt$ & Chr(n)
If Err Then
Err.Clear
Else
Debug.Print "Пароль: " & txt$ & Chr(n)
UnlockSheet = True
Exit Function
End If
Next
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next
End Function
-----------------------------------------------------------------------------
Private Sub Workbook_Open()
'запуск макроса в определенное время (скажем обновление данных)
Application.OnTime TimeValue("12:30:00"), "Update_"
Application.OnTime TimeValue("12:30:10"), "Update_"
Application.OnTime Now + TimeValue("00:00:15"), "my_Procedure"
End Sub
'This example cancels the OnTime setting from the previous example.
Application.OnTime EarliestTime:=TimeValue("17:00:00"), _
Procedure:="my_Procedure", Schedule:=False
-----------------------------------------------------------------------------
l_last_VP = wsVP.Cells(5, 2).CurrentRegion.Rows.Count + 1 'с невидимыми, но прихватывет порой лишнего
l_last_VP = WorksheetFunction.Match("*", wsVP.Range("H:H"), -1) 'идеально! (не чувствительна к QueryTables)
l_last_VP = wsVP.Cells(Rows.Count, 1).End(xlUp).Row 'только видимые
massiv1 = Filter (massiv, «учше») 'фильтрация массива через другой массив (massiv - одномерный массив)
[A1:C4].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[E1:G2], CopyToRange:=[I1], Unique:=False 'расширенный фильтр
sht_all_dl.Cells(2, 1).QueryTable.Refresh BackgroundQuery:=False 'обновляем queryTable не в фоновом режиме
folder$ = GetFolder(777, True) ' запрашиваем имя папки
If folder$ = "" Then Exit Sub ' выход, если пользователь отказался от выбора папки
Dim coll As Collection
' считываем в колекцию coll имена файлов XLS*
Set coll = FilenamesCollection(folder$, "*.xls*")
If coll.Count = 0 Then
MsgBox "В выбранной папке не найдено ни одного файла Excel", vbExclamation
Exit Sub
End If
Аторазмер юзерформ:
UserForm_Resize()
Есть еще проперть как зуум, можно чекнуть.
sht.UsedRange.Value = sht.UsedRange.Value 'сохраняем как значения
-----------------------------------------------------------------------------------------------------------------------------------------
Sheets("aeb_model").Visible = xlVeryHidden 'спрятать лист, что только программно можно открыть
Sub ShowAllSheets()
'сделать видимыми все листы
For Each sht In Sheets
sht.Visible = True
Next
End Sub
-----------------------------------------------------------------------------------------------------------------------------------------
Sub SortAndSuch()
Dim n As Long
Dim lastrow As Long
'if list exists does nothing
Application.AddCustomList ListArray:=Array("JEX", "Q3791J", "YOO5", "KLX9", "GHT")
'get custom list number (plus 1 for 'new list')
n = Application.GetCustomListNum(Array("JEX", "Q3791J", "YOO5", "KLX9", "GHT")) + 1
'get last row Col A
lastrow = Range("A65536").End(xlUp).Row
'Sort Cols A to C by Product then Term
Range("A1:C" & lastrow).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=n, MatchCase:= _
False, Orientation:=xlTopToBottom
'get last row Col A (in case of blanks...)
lastrow = Range("A65536").End(xlUp).Row
'insert blank row between each product group
For i = lastrow To 3 Step -1
If Cells(i, 1) <> Cells(i - 1, 1) Then
Cells(i, 1).EntireRow.Insert
End If
Next i
End Sub
-------------
Буква по столбцу =ЛЕВСИМВ(АДРЕС(1;L30;2);НАЙТИ("$";АДРЕС(1;L30;2))-1)
номер по букве =СТОЛБЕЦ(ДВССЫЛ(ТЕКСТ(L32;"00")&1))
-------------
'создали книгу для проворотов в temp и убили потом
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Kill TempFile
Set TempWB = Workbooks.Add(1)
TempWB.Close savechanges:=False
-----------------------------------------------------------------------------------------------------------------------------------------
With oDict = CreateObject("Scripting.Dictionary")
.Add Key:=1, Item:=Array(11, 12, 13)
.Add Key:=2, Item:=Array(21, 22, 23)
ARR = .Items 'запихиваем в массив весь словарь!
End With
'работает словарь словарей!!!
dicLANG.Add Key:="RUS", Item:=dicRUS
dicLANG.Add Key:="ENG", Item:=dicENG
dicLANG.Add "GER", dicGER
Debug.Print dicLANG.Item("RUS").Item("2")
Debug.Print dicLANG("ENG").Item("2")
Debug.Print dicLANG("GER")("2")
.[K3].Resize(ii) = a
keysArr = .Keys ' Извлекаем массив ключей
itemsArr = .Items ' Извлекаем массив значений
---------
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(arr)
.Item(arr(i, 1)) = i
Next i
For i = 1 To UBound(c)
If .Exists(c(i, 1)) Then arr(.Item(c(i, 1)), 3) = c(i, 2)
Next i
End With
----------------------------------------------------------------------
Sub ClearContent(sht_for_clearing As String)
'удаляет кроме первой строки
Dim curWB As Worksheet, s_lastcol$
Set curWB = ThisWorkbook.Worksheets(sht_for_clearing)
s_lastcol = Split(curWB.UsedRange.Address, ":")(1)
curWB.Range("A2:" & s_lastcol).ClearContents
'Подтираем за собой
Set curWB = Nothing
End Sub
----------------------------------------------------------------------
With CreateObject("Scripting.FileSystemObject")
.DeleteFolder (ThisWorkbook.Path & ps & sCutFolder)
.createfolder (ThisWorkbook.Path & ps & sCutFolder)
End With
----------------------------------------------------------------------
Function IsInArray(SearchValue As Variant, TargetArray As Variant) As Boolean
Dim Dimension As Byte
Dim j As Long
On Error Resume Next
If IsError(UBound(TargetArray, 2)) Then Dimension = 1 Else Dimension = 2
On Error GoTo 0
Select Case Dimension
Case 1
On Error Resume Next
IsInArray = Application.Match(SearchValue, TargetArray, 0)
On Error GoTo 0
Case 2
For j = 1 To UBound(TargetArray, 2)
On Error Resume Next
IsInArray = Application.Match( _
SearchValue, _
Application.Index(TargetArray, , j), _
0 _
)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Select
End Function
----------------------------------------------------------------------
=ИНДЕКС(13:27;АГРЕГАТ(15;6;(СТРОКА(13:27)-12)/(8=13:27);I$7))
- это 1я, 2я и т.д. ВПРки
Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _
Optional ByVal InitialPath As String = "c:\") As String
' функция выводит диалоговое окно выбора папки с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора
Dim PS As String: PS = Application.PathSeparator
With Application.FileDialog(msoFileDialogFolderPicker)
If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
.ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
If .Show <> -1 Then Exit Function
GetFolderPath = .SelectedItems(1)
If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
End With
End Function
Sub ПримерИспользования_GetFolderPath()
ПутьКПапке = GetFolderPath("Заголовок окна", ThisWorkbook.Path) ' запрашиваем имя папки
If ПутьКПапке = "" Then Exit Sub ' выход, если пользователь отказался от выбора папки
MsgBox "Выбрана папка: " & ПутьКПапке, vbInformation
End Sub
Function GetFilePath(Optional ByVal Title As String = "Выберите файл для обработки", _
Optional ByVal InitialPath As String = "c:\", _
Optional ByVal FilterDescription As String = "Книги Excel", _
Optional ByVal FilterExtention As String = "*.xls*") As String
' функция выводит диалоговое окно выбора файла с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранному файлу, или пустую строку в случае отказа от выбора
' для фильтра можно указать описание и расширение выбираемых файлов
On Error Resume Next
With Application.FileDialog(msoFileDialogOpen)
.ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
.Filters.Clear: .Filters.Add FilterDescription, FilterExtention
If .Show <> -1 Then Exit Function
GetFilePath = .SelectedItems(1): PS = Application.PathSeparator
End With
End Function
Sub ПримерИспользования_GetFilePath()
ИмяФайла = GetFilePath("Выберите файл Word", , "Документы Word", "*.doc") ' запрашиваем имя файла
If ИмяФайла = "" Then Exit Sub ' выход, если пользователь отказался от выбора файла
MsgBox "Выбран файл: " & ИмяФайла, vbInformation
End Sub
Function GetFilenamesCollection(Optional ByVal Title As String = "Выберите файлы для обработки", _
Optional ByVal InitialPath As String = "c:\") As FileDialogSelectedItems
' функция выводит диалоговое окно выбора нескольких файлов с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает массив путей к выбранным файлам, или пустую строку в случае отказа от выбора
With Application.FileDialog(3) ' msoFileDialogFilePicker
.ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
If .Show <> -1 Then Exit Function
Set GetFilenamesCollection = .SelectedItems
End With
End Function
Sub ПримерИспользования_GetFilenamesCollection()
Dim СписокФайлов As FileDialogSelectedItems
Set СписокФайлов = GetFilenamesCollection("Заголовок окна", ThisWorkbook.Path) ' выводим окно выбора
' ===================== другие варианты вызова функции =====================
' стартовая папка не указана, заголовок окна по умолчанию
Set СписокФайлов = GetFilenamesCollection
' обзор файлов начинается с папки "Рабочий стол"
СтартоваяПапка = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Set СписокФайлов = GetFilenamesCollection("Выберите файлы на рабочем столе", СтартоваяПапка)
' ==========================================================================
If СписокФайлов Is Nothing Then Exit Sub ' выход, если пользователь отказался от выбора файлов
For Each File In СписокФайлов
Debug.Print File
Next
End Sub
'дает возможность фильтровать объединенные ячейки
Sub ReMerge(rng As Range)
Dim rRange As Range, rMrgRange As Range, wsTempSh As Worksheet, wsActSh As Worksheet
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Set wsActSh = ActiveSheet: Set wsTempSh = Sheets.Add(, Sheets(Sheets.Count)): wsTempSh.Name = "anyName"
wsActSh.Activate
Set rRange = rng: rRange.Copy wsTempSh.Range(rRange.Address)
Set rMrgRange = wsTempSh.Range(rRange.Address)
rng.UnMerge
rng.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
rMrgRange.Copy: rRange.PasteSpecial xlPasteFormats: wsTempSh.Delete
Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub
SQL:
cn.ConnectionString = "Provider=SQLOLEDB.1;" & _
"Integrated Security=SSPI;Persist Security Info=True;" & _
"Data Source=crm-sql2\sqlinst;Use Procedure for Prepare=1;" & _
"Auto Translate=True;Packet Size=4096;Workstation ID=FPOTOKIN2;" & _
"Use Encryption for Data=False;Tag with column collation when possible=False;" & _
"Initial Catalog=Carcade_MSCRM" 'Параметры строки подключения" ; HDR=1 ; Extended Properties='HDR=YES'
cn.CommandTimeout = 3600 'увеличиваем время запроса, чтобы не вылетала ошибка "вермя ожидания запроса истекло"
cn.Open
str_sql_query = sht_main.Range("H" & load_row).Value 'наш SQL запрос
rst.Open str_sql_query, cn, adOpenStatic 'SQL-запрос, подключение (не оборачиваем в кавычки, т.к. ЭСКУЭЛ считает это идентификатором, а у него 128 символов ограничение!)
''Workbooks("FORM 30.xlsx").Sheets("ДКУ").Range("A2").CopyFromRecordset rst 'Извлекаем данные на лист
ThisWorkbook.Sheets(sht_name).Range("A2").CopyFromRecordset rst 'Извлекаем данные на лист
--------------------------------------------------------
'открыли книгу, обновлили, запустили в ней макрос, закрыли книгу сохранив
Workbooks.Open "C:\sql выгрузки\выгрузки.xlsb", 3
Call Application.Run("'выгрузки для отчета по заявкам.xlsb'!LoadSQLDataForOrdersReport")
Workbooks("выгрузки.xlsb").Close True
'проверка присутствия файла с выбором действия
If Dir(str_Cur_Order_report_Path) <> "" Then
answer = MsgBox("Отчет с названием " & str_Cur_Order_report & " уже существует! Заменить (Да) или выйти (Нет)?", vbYesNo)
If answer = vbNo Then Exit Sub
End If
Set fso = CreateObject("Scripting.FileSystemObject")
'проверка существования папок, если их нет, то создаем
If fso.FolderExists(str_year_folder) = False Then fso.CreateFolder (str_year_folder) 'год
FileCopy obj_Main.Range("D38").Value & "\" & str_prev_order_report, str_month_folder & "\" & str_prev_order_report
If fso.FileExists(new_name) Then Kill new_name 'если файл существует, то удаляем его
fso.CopyFile VoronkaFolder & "/Шаблон для отправки.xlsx", CurrentDepartmentPath, 0 'копируем файл
'вставляем скопированное сразу в 3 ячейки транспонируя
ThisWorkbook.Sheets("Праздники").Range("D5:D35").Copy
wb_last_prev.Range("F1, AS1, CK1").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Workbooks(str_Cur_Order_report).Sheets(Array("ЛС", "ДЛ", "прошлый")).Delete 'удаляем сразу пачку листов
Workbooks("форма.xlsx").Sheets("ДЛ").Cells.Replace What:="MO9: Подразделение МО-9", Replacement:= _
"MOКП: Подразделение МО-15", LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
person_int.Cells.WrapText = False 'запретить перенос строк
Function getValue(search$, text$) As Double
Dim arr() As String, num As Long
text = Replace(text, "= ", "")
text = Replace(text, ".", ",")
arr = Split(text, " ")
num = Application.Match(search, arr, 0)
getValue = arr(num)
End Function
Sub GroupSelectionLikePivot()
'группируем строки по цвету
'выделяем диапазон для группировки
last1 = 0: last2 = 0
l_row = Selection.Row
i_col = Selection.Column
'получаем цвета
lastrowinsel = Selection.Count + l_row - 1
For j = l_row To lastrowinsel
i = 1
If Cells(j, i_col).IndentLevel = 2 Then
Do While Cells(j, i_col).Offset(i).IndentLevel <> 2 _
And Cells(j, i_col).Offset(i).IndentLevel <> 2
i = i + 1
If i + j = lastrowinsel Then Exit Do
Loop
last1 = j + i - 1
Rows(j + 1 & ":" & last1).Group
If i + j = lastrowinsel Then Exit For
j = last1
End If
Next
For j = l_row To lastrowinsel
i = 1
If Cells(j, i_col).IndentLevel = 1 Then
Do While Cells(j, i_col).Offset(i).IndentLevel <> 1
i = i + 1
If i + j = lastrowinsel Then Exit Do
Loop
last1 = j + i - 1
Rows(j + 1 & ":" & last1).Group
If i + j = lastrowinsel Then Exit For
j = last1
End If
Next
End Sub
Function СЧЁТСИМВЛ(ТЕКСТ As String, СИМВОЛ As String) As Long
Dim i As Long
Dim S As Long
S = 0
For i = 1 To Len(ТЕКСТ)
If СИМВОЛ = Mid(ТЕКСТ, i, 1) Then S = S + 1
Next
СЧЁТСИМВЛ = S
End Function