Vba_Helper - Под разбор

'меняем тип ссылок на диапазоны
Dim cell As Range
    If Selection.Cells.Count > 1 Then
        Set rng = Selection.SpecialCells(xlCellTypeFormulas)
    Else
        Set rng = ActiveCell
    End If
        For Each cell In rng
            If Not cell.HasArray Then cell.Formula = Application.ConvertFormula(Formula:=cell.Formula, FromReferenceStyle:=xlA1, ToReferenceStyle:=xlA1, ToAbsolute:=xlAbsolute)
        Next cell
'открываем папку файла
    Set WshShell = CreateObject("WScript.Shell")
    MyPath = """" & ActiveWorkbook.Path & """"
    Shell "explorer.exe " & MyPath, vbNormalFocus
или CreateObject("Shell.Application").Explore ActiveWorkbook.Path
'отпарвить текущий лист через outlook
    On Error Resume Next
    Application.Dialogs(xlDialogSendMail).Show
'удаление всех группировок на активном листе
    On Error Resume Next
    ActiveSheet.UsedRange.ClearOutline
'формат с разделителями (посмотреть и другие форматы)
    If TypeName(Selection) <> "Range" Then Exit Sub
    Selection.NumberFormat = "#,##0"
'инициализация формы
    Me.StartUpPosition = 0
    Me.Left = CInt(GetSetting("Addin1", Me.Name, "PosX", 100))
    Me.Top = CInt(GetSetting("Addin1 ", Me.Name, "PosY", 100))
    If Selection.Columns.Count = 1 Then optByColumns.Value = True
    If Selection.Rows.Count = 1 Then optByRows.Value = True
'тут у нас ускорение
    Application.DisplayAlerts = False
    CalcMode = Application.Calculation
    RefStyle = Application.ReferenceStyle
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
'а тут возвращаем смотрибельные настройки на выходе
    Application.DisplayAlerts = True
    If IsEmpty(CalcMode) Then
        Application.Calculation = xlCalculationAutomatic
    Else
        Application.Calculation = CalcMode
    End If
    Application.ReferenceStyle = RefStyle
    Application.ScreenUpdating = True

Sub ShowAllSheets()
'отображает все скрытые листы в книге
    On Error Resume Next
    For Each sh In ActiveWorkbook.Sheets
        sh.Visible = True
    Next sh
End Sub

Sub SuperHideSheet()
'делает текущий лист суперскрытым
    On Error Resume Next
    ActiveSheet.Visible = xlVeryHidden
End Sub

Sub checkPivot()
    'проверяем выделение на пересечение со сводными
    If ActiveSheet.PivotTables.Count > 0 Then
        For Each cell In ActiveSheet.UsedRange
            On Error Resume Next
            pvtTable = cell.PivotTable.Name
            If Len(pvtTable) > 0 Then
                SelectionCheck = False
                Exit Sub
            End If
        Next cell
    End If
End Sub

Sub ГородаРегионаДляСводной()
Dim a1 As Shape
Set a1 = Nothing
Set a1 = ActiveSheet.Shapes("Раскр. список 1")
ActiveSheet.PivotTables("СводнаяТаблица7").PivotFields("Регоин").CurrentPage = Sheets("впр").Cells(1, 7).Value ' тут указан регион прописью
ActiveSheet.Shapes.Range(Array("Drop Down 2")).Select
    With Selection
        .ListFillRange = ActiveWorkbook.Sheets("впр").Range("I1").Value
        .LinkedCell = "2"
        .DropDownLines = 8
        .Display3DShading = False
    End With
Range("b1").Select
End Sub

Public Function ъГородаРегиона(регион As Range, столбец_регионов As Range, столбец_городов As Range, Optional разделитель As String) As String
Dim s_ans$, i%
For Each cell In столбец_регионов
i = i + 1
    If cell = регион Then
        s_ans = s_ans & разделитель & столбец_городов.Cells(i, 1).Value
    End If
Next
ъГородаРегиона = Mid(s_ans, Len(разделитель) + 1)
End Function

'фильтруем сразу по всем заначениям массива arr
        ActiveSheet.Range("1:1194").AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues

'дает возможность фильтровать объединенные ячейки
Sub ReMerge()
    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 = Selection: rRange.Copy wsTempSh.Range(rRange.Address)
    Set rMrgRange = wsTempSh.Range(rRange.Address)
    Selection.UnMerge
    Selection.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    rMrgRange.Copy: rRange.PasteSpecial xlPasteFormats: wsTempSh.Delete
    Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

ActiveSheet.Shapes.AddLine(114.25, 135.75, 230.25, 146.25).Select

'рисует линию по координатам

ActiveSheet.Shapes(3).Select

' выделяет графический объект (нумерация по созданию)

ActiveSheet.Shapes("MO2").Select

' выделяет графический объект по названию, которое сначало должно быть присвоено этому объекту

ActiveSheet.Shapes(3).name = "MO2"

ActiveSheet.Shapes("Овал 6").Select

так задаем имя фигуре

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 'только видимые

LastRow = Cells(Rows.Count, 1).End(xlUp).Row						последняя заполненная строка в столбце
LastRow = Cells.SpecialCells(xllastcell).row(column)						последняя используемая (когда-либо) строка на листе
LastColumn = Cells(1, Columns.Count).End(xltoLeft).Column						последний заполненный столбец в указанной строке\
firstrow = Cells(1, Range("j1").Column).End(xlDown).Row						номер строки первой заполненой

a=3: b=4. : - разделитель

str_slashNumber = InStrRev(avFiles(2), "\") - ищем в avFiles(2) "\" с обратной стороны

Здесь стартовой назначается папка, в которой расположен исходный файл EXCEL с кодом.
Private Sub CommandButton1_Click()
'Смена текущего диска:
ChDrive Left(ThisWorkbook.Path, 1)
'Смена текущего каталога:
ChDir ThisWorkbook.Path
Range("A1") = Application.GetOpenFilename
End Sub
Если выбрать файл, в ячейку «А1» запишется полный путь к нему, иначе, при отмене выбора, запишется «Ложь».

S = Interaction.InputBox("Введите число")

If S = "" Then Exit Sub 'завершаем процедуру, если строка пуста

Cells(i, 1).Interior.Color = RGB(255, 55, 0)

задаем цвет

Application.Volatile - для пересчета функции при изменении любой другой ячейки.

Public Declare Function timeGetTime Lib "winmm.dll" () As Long 'объявляем библиотеку

Selection.SpecialCells(xlCellTypeComments).delete - удаляем все комментарии из книги.
Выделяем пусты ячейки: диапазон-выпадающий список-правка-перейти-выделить пустую ячейку.

ActiveWindow.ScrollRow = 1 'Прокрутка

Columns("A:A").Range("A1:A9").RemoveDuplicates Columns:=1, Header:=xlNo ' удаляем дубликаты

Worksheets(2).Hyperlinks.Add Anchor:=Cells(5,1), Address:="", SubAddress"=Worksheets(1).Name & "!" & Cells(1,1).Address, TextToDisplay"="123"
Гиперссылка, где Anchor - куда пишем ссылку, SubAddress - ссылка во внутренний док-т, Address - во внешний
Workbooks(wbreport).Worksheets("Отчет").Rows.Hidden = True '- раскрывает все группировки
Workbooks(wbreport).Worksheets("Отчет").Rows(35).ShowDetail = False 'закрывает группировку
Workbooks(wbreport).Worksheets("Отчет").Columns("D").ShowDetail = False 'закрывает группировку в указанном столбце
Workbooks(wbreport).Worksheets("Отчет").Outline.ShowLevels , 3 '- раскрыли группировку на 3-м уровне
Workbooks(wbreport).Worksheets("Отчет").Outline.ShowLevels , 1 ' свернули группировку на 1-м уровне
Workbooks(wbForma).SaveAs Filename:="\С:\Рассылка\Форма"
Workbooks(wbreport).SaveAs Filename:=Workbooks(wbreport).Path & Replace(wbreport, ".xlsx", "_.xlsx")
Workbooks(wbreport).Worksheets(Array("ЛС", "ДЛ", "прошлый")).Delete 'пачку листов удаляем

KPI.Range("AE" & k + 1 & ":AE" & n).FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-30],'[План показатели.xlsb]" & m_Name & "'!R4C2:R1307C50,15,0),"""")" 'НСиб

Rows("13:13").Delete Shift:=xlUp — удалить строку 13 со сдвигом вверх.
FilterOn = Workbooks(city).Sheets("Список договоров").AutoFilterMode
If FilterOn = False Then Workbooks(city).Sheets("Список договоров").Cells.AutoFilter

datebegin = Format(sh1.Cells(2, 8), "00")
ActiveSheet.Cells.AutoFilter field:=3, Criteria1:=">" & datebegin
Workbooks(city).Sheets(R_Sheets).Range(R_range_new_del).ClearContents - очистить значения в диапазоне
Union(Range("W6:W7"), Range("W10:W11")).ClearContents - объединение диапазонов

ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - количество видимых строк
или промежуточные.итоги(2,столбец()) может еще ЧСТРОК()
GeneralFile.SaveAs Filename:=GeneralFolder & "\" & curfilename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
Replace_symbols ("sd""") - ставим одну кавычнку - в vba - это две кавычки внутри одинарных кавычек!

Dir() - проверяет присутствие директории, файла, по пути, если нет, то ошибка, допускает * и ? (один символ)
& vbLf & _ переносим на след строку
Application.Goto "Open_Code_Editor.open_code_editor" 'открыть редактор кода в месте "Имя Модуля.Имя Макроса"
wbForSending = Replace(wbreport, ".xlsx", "_.xlsx") ' быстрая переименовка

RunTime = Format(Fix(Timer - T) / 86400, "h:mm:ss") & Format(Timer - T - Fix(Timer - T), ".00000")
Dim T As Single
T = Timer
MsgBox "Execution Time: " & Format(Fix(Timer - T) / 86400, "h:mm:ss") & Format(Timer - T - Fix(Timer - T), ".00000")

удаление строк по пустым ячейкам в указанном диапазоне
range("my range").specialCells(xlCellTypeBlanks).EntireRow.Delete
.Delete shift:=xlup ' со сдвигом наверх
Невидимый Excel
Dim objExcel as new excel.application
app.oleRequestPendingTimeout = 200000 ' ставим таймаут, чтобы не вылетело "Pending…", т.е. "в ожидании"
objexcel.Visible = false

Диалоговое окно для выбора файлов.
avFiles = Application.GetOpenFilename _
    ("Excel files(*.xl*),*.xl*", 2, "Выбрать текстовые или Excel файлы", , True) ',Text files(*.txt),*.txt

int_File_Number = UBound(avFiles) 'количество выбранных файлов
str_File_name = Dir (FullPah) ' если файл есть то сохранит название, если нет, то ошибка

Цвет шрифта: Font.color=528, или vbRed, или ColorConstants.vb…
Поиск в строке: instr(1,text, "_"), instrrev(text,"_")
Selection.EntireRow.Insert - Вставить строку, остальное сдвинется вниз

Для проверки всех видимых и невидимых файлов.
    If Windows(wbBook.Name).Visible Then
        If wbBook.Name = wbName Then IsBookOpen = True: Exit For

sStr = CLng.Strings.Join(chars)
vLen = ALength(v) 'простая фунция, возвращающая длину одномерного массива
            interes.Range("A" & n & ":N" & k - 1).Copy ' копируем найденый диапазон с тек. подр-м
            person_int.Cells(2, 1).PasteSpecial Paste:=xlPasteValues ' вставляем в файл воронки
Erase arr_crm_forma 'очищаем массив весь

    Dim FileSystemObject As Object
    Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
    Dim f As Object
    Set f = FileSystemObject.GetFolder(FolderPath)
f.SubFolders
f.Files

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range

    ' The variable KeyCells contains the cells that will
    ' cause an alert when they are changed.
    Set KeyCells = Range("A1:C10")

    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then

        ' Display a message when one of the designated cells has been
        ' changed.
        ' Place your code here.
        MsgBox "Cell " & Target.Address & " has changed."

    End If
End Sub

Public Function FindReverse(rng As Range, match As String) As Integer
'функция НАЙТИ задом наперед
FindReverse = InStrRev(rng, match)
End Function

Sub GroupSelectionLikePivot()
'группируем строки по цвету
'выделяем диапазон для группировки
last1 = 0: last2 = 0
l_row = Selection.Row
i_col = Selection.Column

'получаем цвета
color1 = Cells(l_row, i_col).Interior.Color
color2 = Cells(l_row + 1, i_col).Interior.Color
lastrowinsel = Selection.Count + l_row - 1
For j = l_row To lastrowinsel
    i = 1
    If Cells(j, i_col).Interior.Color = color2 Then
        Do While Cells(j, i_col).Offset(i).Interior.Color <> color2 _
            And Cells(j, i_col).Offset(i).Interior.Color <> color1
            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).Interior.Color = color1 Then
        Do While Cells(j, i_col).Offset(i).Interior.Color <> color1
            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

Sub saveAttachments()
'сохраняем все вложения в выделенной папке Outlook
    Dim objOutlookApp As Object
    Dim sExt$, sFolderPath$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
            On Error Resume Next
               'пробуем подключиться к Outlook, если он уже открыт
            Set objOutlookApp = GetObject(, "Outlook.Application")
            Err.Clear 'Outlook закрыт, очищаем ошибку
            If objOutlookApp Is Nothing Then
                Set objOutlookApp = CreateObject("Outlook.Application")
            End If
            'произошла ошибка создания объекта - выход
            If Err.Number <> 0 Then Set objOutlookApp = Nothing: Exit Sub
            objOutlookApp.session.Logon

sFolderPath = ActiveSheet.Range("b5").Value
If Dir(sFolderPath, vbDirectory) = "" Then MsgBox "Не существует указанной папки. Создайте её сначала": Exit Sub

ActiveSheet.Range("A7:A" & ActiveSheet.Columns(1).SpecialCells(xlLastCell).Row).ClearContents

    For Each oItem In objOutlookApp.Explorers.Item(1).currentfolder.items
        For Each att In oItem.attachments
        sExt = ФАЙЛРАСШИР(att)
        If sExt <> "png" And sExt <> "jpg" And sExt <> "gif" Then
            If ActiveSheet.Range("C3").Value = True And Dir(sFolderPath & "\" & att.Filename) = "" Then
                att.SaveAsFile sFolderPath & "\" & att.Filename
            Else
                 att.SaveAsFile sFolderPath & "\" & Replace(att.Filename, "." & sExt, " (2)." & sExt)
            End If
            ActiveSheet.Cells(Application.Match("*", ActiveSheet.Columns(1), -1) + 1, 1).Value = att.Filename
        End If
        Next
    Next

Set objOutlookApp = Nothing
Set oItem = Nothing: Set oItem = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Готово!"
End Sub

Sub Открыть_папку_по_пути_из_ячейки()
Dim found_cell As Range, sCell$

Set found_cell = Cells.Find(What:="Путь папки", LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
sCell = Cells(found_cell.Row, found_cell.Column + 1).Text
Open_Folder_by_Path (sCell)

Set found_cell = Nothing
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

Sub collect_data_from_files_in_folder()
'собираем данные из файлов в указанной папке
Dim sFolderPath$
Application.ScreenUpdating = False
Application.DisplayAlerts = False

sFolderPath = ActiveSheet.Range("B5").Value
arrFiles = Files_in_Folder(sFolderPath)

Set WSPivot = Workbooks.Add(1)
Set WSPivot = WSPivot.Sheets(1)

For Each sFile In arrFiles
    sFilePath = Dir(sFolderPath & "\" & sFile)
    If sFilePath <> "" Then 'т.к. есть скрытые файлы
        Set oFile = Workbooks.Open(sFolderPath & "\" & sFile)

        lastrow = WSPivot.Cells(Rows.Count, 1).End(xlUp).Row + 1
        oFile.Sheets(1).Cells(1, 1).CurrentRegion.Copy
        WSPivot.Cells(lastrow, 1).PasteSpecial
        oFile.Close False
    End If
Next

Set WSPivot = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Function Files_in_Folder(ByVal Folder$) As String()
    Dim N%
    Dim fs, f, f1
    Dim Folders() As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Folder)

    N = 0
    On Local Error Resume Next
    For Each f1 In f.Files
      N = N + 1
      ReDim Preserve Folders(1 To N) As String
      Folders(N) = f1.Name '& "\"
   Next f1
   Files_in_Folder = Folders
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

ДОБАВИТЬ В КОНТЕКСТНОЕ МЕНЮ ЯЧЕЕК:
Если один раз выполнить код:

Sub Add_PasteSpecials()
 Dim cbb
 Set cbb = Application.CommandBars("Cell").FindControl(ID:=370)
 If Not cbb Is Nothing Then cbb.Delete 'удаляем пункт, если он был уже добавлен ранее
 Application.CommandBars("Cell").Controls.Add ID:=370, before:=4
End Sub

Sub Add_PasteSpecials()

Dim cbb

Set cbb = Application.CommandBars("Cell").FindControl(ID:=370)

If Not cbb Is Nothing Then cbb.Delete 'удаляем пункт, если он был уже добавлен ранее

Application.CommandBars("Cell").Controls.Add ID:=370, before:=4

End Sub

то в контекстном меню мыши появится команда - "Вставить значения". Она полностью дублирует стандартную, только вызвать её быстрее - одно нажатие и все.

'удаляем связи (подключения)
n = copybook.Connections.Count
For i = 1 To n
copybook.Connections(1).Delete
Next

Vba helper

programming