Option Explicit

Sub AutoFillToRow(rngBeg As Range, rEnd As Long)
Dim rngEnd As Range
With rngBeg
  If rEnd >= .Row Then
    Set rngEnd = .Resize(rEnd - .Row + 1)
  Else
    If rEnd < .Row Then Set rngEnd = .Offset(rEnd - .Row).Resize(.Row - rEnd + .Rows.Count)
  End If
  .AutoFill Destination:=rngEnd, Type:=xlFillDefault
End With
End Sub

Sub Заполнить()
Dim x, firstRowData As Long, rEnd As Long, rngUsed As Range, rngBeg As Range
Set rngUsed = ActiveSheet.UsedRange
firstRowData = 12 'первая строка данных в таблице
rEnd = rngUsed.Row + rngUsed.Rows.Count - 1 'последняя используемая строка на листе
For Each x In Array(1, 2, 5, 6, 13, 14, 15, 21) 'в каких столбцах нужен AutoFill
  Set rngBeg = Cells(firstRowData, x) 'за основу первая строка данных таблицы
'  Set rngBeg = Range(Cells(firstRowData, x), Cells(rEnd - 1, x))'за основу диапазон кроме последней строки данных таблицы
  AutoFillToRow rngBeg, rEnd
Next
End Sub

Function WebDavDsk(lgn$, psw$, Optional fldr$) As String
Dim fso As Object, netDsk As Object, dskPath$, i&
Set netDsk = CreateObject("WScript.Network")
Set fso = CreateObject("Scripting.FileSystemObject")
  On Error Resume Next
  For i = 65 To 90
    dskPath = Chr(i) & ":"
    If Not fso.DriveExists(dskPath) Then
      netDsk.MapNetworkDrive dskPath, "https://webdav.yandex.ru:443/" & fldr, False, lgn, psw
      If Err.Number = 0 Then Exit For Else dskPath = "": Err.Clear
    End If
  Next
  On Error GoTo 0
WebDavDsk = dskPath
End Function

Sub NetDskOff(dskPath$)
Dim fso As Object, x, netDsk As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set netDsk = CreateObject("WScript.Network")
On Error Resume Next
For Each x In fso.Drives
  dskPath = x.Path: If fso.FolderExists(dskPath) Then netDsk.RemoveNetworkDrive dskPath, True, True: Exit For
Next
End Sub

Sub ПримерИспользования()
Dim БукваПодключаемогоДиска$
БукваПодключаемогоДиска = WebDavDsk("Логин", "Пароль", "Папка")
'vcomp71 написал: Загрузить файл, скачать, создать директорию, переименовать
'Здесь все это делаем что хотели

NetDskOff БукваПодключаемогоДиска 'Отключаем диск после работы
End Sub

Option Explicit

Sub UnqVal(ctrl, a)
Dim i As Long, d As Object
With Me.Controls(ctrl)
  .List = a: If .ListCount = 0 Then Exit Sub
  Set d = CreateObject("Scripting.Dictionary"): d.CompareMode = 1
  Do While i < .ListCount
    If d.exists(.List(i, 0)) Then .RemoveItem (i) Else d(.List(i, 0)) = Empty: i = i + 1
  Loop
End With
End Sub

Private Sub UserForm_Initialize()
UnqVal "ComboBox1", Array("a", "b", "c", "b", "c", "d", "a")
End Sub

Filename = L1.Cells(6, 31) & ".xlsx"

Sub Аптека()
Dim wbkSource As Workbook
  Set wbkSource = Workbooks.Open(ActiveSheet.Range("A1"), Password:="0301")
  wbkSource.Sheets(ThisWorkbook.ActiveSheet.Range("B2").Value).Activate
End Sub

Private Sub Workbook_Open()
Dim wks As Worksheet
For Each wks In Worksheets
  With wks
    If .AutoFilterMode Then If .AutoFilter.FilterMode Then .ShowAllData
  End With
Next
End Sub

Sub Аптека()
  Set wbkSource = Workbooks.Open(Range("A1"), Password:="0301")
  wbkSource.sheets(thisworkbook.activesheet.Range("B2")).activate
End Sub

Public Sub Auto_Open()
    Dim wks As Worksheet
   For Each wks In Worksheets
        with wks
            If .AutoFilterMode Then If .AutoFilter.FilterMode Then .ShowAllData
        end with
    next
end sub

Sub TestCopyValue()
Dim aField, x, xColumn as range, c&
shNm1 = "Лист1"
shNm2 = "Лист2"
aField = Array("Столбец A1", "Столбец B1", "Столбец D1")
For Each x In aField
  Set xColumn = GetColumnRange(shNm1, x, 1)
  If Not xColumn Is Nothing Then c = c + 1: Sheets(shNm2).Cells(2, c).Resize(xColumn.Count).Value = xColumn.Value
Next
End Sub

Function GetColumnRange(ByVal nmSheet, ByVal nmField, Optional ByVal rField& = 1) As Range
Dim x, i&
With Sheets(nmSheet).UsedRange
  If rField < .Row Then rField = .Row
  With .Offset(rField - .Row).Resize(.Rows.Count - rField + .Row)
    For Each x In .Resize(1)
      If nmField = x Then Set GetColumnRange = .Offset(1, i).Resize(.Rows.Count - 1, 1): Exit Function
      i = i + 1
    Next
  End With
End With
End Function

Sub ВыделитьНеобходимыйДиапазон()
Dim ИмяЛиста$, ИмяНужногоПоля$, НомерСтрокиЗаголовков&
ИмяЛиста = "Лист1"
ИмяНужногоПоля = "ID"
НомерСтрокиЗаголовков = 1
GetColumnRange(ИмяЛиста, ИмяНужногоПоля, НомерСтрокиЗаголовков).Select
End Sub

Function SetListBoxRowsCount(lst As Control, Optional ByVal rCount&, Optional rAuto As Boolean)
Dim d, hAdd!, r&, lHeight!, iHeight As Boolean
Static y!
On Error Resume Next
With lst
  If rCount > 0 Then
    If y Then
      If rAuto Then If rCount > .ListCount Then rCount = .ListCount
      .IntegralHeight = False: .Height = y * (rCount + 1): .IntegralHeight = True: DoEvents
      SetListBoxRowsCount = y: Exit Function
    End If
  Else
    lHeight = .Height: iHeight = .IntegralHeight
  End If
  r = 1
  Set d = CreateObject("Scripting.Dictionary")
  .IntegralHeight = False: .Height = lst.Font.Size * 0.75: .IntegralHeight = True: DoEvents
  hAdd = .Height + 1.5: y = .Height
  Do Until r >= 10
    .IntegralHeight = False: .Height = .Height + hAdd: .IntegralHeight = True: DoEvents
    y = Round((.Height - y) / 0.75): d(y) = d(y) + 1: If d(y) * 2 - 3 > d.Count Then Exit Do
    y = .Height: r = r + 1
  Loop
  y = y * 0.75: .IntegralHeight = False:
  If lHeight > 0 Then
    .Height = lHeight + y: .IntegralHeight = True: DoEvents: .IntegralHeight = iHeight
  Else
    .Height = y * (rCount + 1): .IntegralHeight = True: DoEvents
  End If
End With
SetListBoxRowsCount = y
End Function