Option Explicit
Dim EA As Excel.Application
Dim WB As Excel.Workbook
Dim WS As Excel.Worksheet
Dim strValue$, idcode&, strSQL$
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

Public Sub transferAccPr()

Set EA = Excel.Application

EA.ScreenUpdating = False
EA.DisplayAlerts = False
EA.StatusBar = False

Set EA = Excel.Application
Set WB = EA.Workbooks("TestExcel.xlsm")
Set WS = WB.Worksheets("Лист1")

Set cn = New ADODB.Connection
cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\TestAccessBD.accdb;"
cn.Open

strValue = WS.Cells(2, 2).Value
idcode = WS.Cells(2, 1).Value

'strSQL = "SET NOCOUNT ON UPDATE Products SET [Item] = " & " '" & strValue & "'" & " WHERE Products.[CodeId]= 4"
strSQL = "UPDATE Products SET [Item] = " & " '" & strValue & "'" & " WHERE Products.[CodeId]= 4"

Set rs = cn.Execute(strSQL)

rs.Close

cn.Close

EA.ScreenUpdating = True
EA.DisplayAlerts = True

End Sub

Option Explicit
Dim WEA As Excel.Application
Dim WB As Excel.Workbook 
Dim WS As Excel.Worksheet 
Dim strValue$(1 To 10)
Dim nRegExp As RegExp


Public Sub replaceValue()

Set WEA = Excel.Application

WEA.ScreenUpdating = False
WEA.DisplayAlerts = False
WEA.StatusBar = False

Set WEA = Excel.Application
Set WB = WEA.Workbooks("Замен внутри скобок.xlsm")
Set WS = WB.Worksheets(1)

Set nRegExp = New RegExp

With WS

strValue(1) = .Cells(1, 1).Value
strValue(3) = Replace(strValue(1), "(*)", "")

nRegExp.Pattern = "(w\*)"
strValue(2) = nRegExp.Replace(strValue(1), "")


End With


WEA.ScreenUpdating = True
WEA.DisplayAlerts = True

End Sub

Dim WEA As Excel.Application
Dim WB As Excel.Workbook
Dim WS As Excel.Worksheet
Dim arrTest

Public Sub replaceValue()

Set WEA = Excel.Application

WEA.ScreenUpdating = False
WEA.DisplayAlerts = False
WEA.StatusBar = False

Set WEA = Excel.Application
Set WB = WEA.Workbooks("Длина массива.xlsm")
Set WS = WB.Worksheets(1)


arrTest = Array(1, 2, 3, 43, 5)
'i = arrTest.Ubound

WEA.ScreenUpdating = True
WEA.DisplayAlerts = True

End Sub

Dim WEA As Excel.Application
Dim WB As Excel.Workbook
Dim WS As Excel.Worksheet
Dim WSR As Range
Dim regDate As RegExp
Dim srtDate

Public Sub regExpProcedure()

Set WEA = Excel.Application

WEA.ScreenUpdating = False
WEA.DisplayAlerts = False

Set WEA = Excel.Application
Set WB = WEA.Workbooks("Ðåãóëÿðíîå âûðàæåíèå.xlsm")
Set WS = WB.Worksheets(1)
Set regDate = New RegExp

With WS

For Each WSR In Range(.Cells(1, 1), .Cells(1, 4))

        If WSR.Value Like regDate.Pattern = ("\w{2}.\w{2}.\w{4}") Then strDate = WSR.Value

Next WSR

End With

WEA.ScreenUpdating = True
WEA.DisplayAlerts = True

End Sub

Option Explicit
Option Base 1
Dim WEA As Excel.Application
Dim WB(1 To 30) As Excel.Workbook 
Dim WS(1 To 30) As Excel.Worksheet
Dim i&, y&, n&, k&
Dim iLastRow&(1 To 30) 
Dim iLastColumn&(1 To 30)

Public Sub test_Procedure()
Set WEA = Excel.Application

WEA.ScreenUpdating = False 
WEA.DisplayAlerts = False 

Set WEA = Excel.Application
Set WB(1) = WEA.Workbooks("Двухмерный динамичный массив.xlsm")
Set WS(1) = WB(1).Worksheets(1)

iLastRow(1) = LastRow_FA(WS(1), 1)
iLastColumn(1) = LastColumn_FA(WS(1), 1)

For n = 1 To iLastRow(1)      
    For i = 1 To iLastColumn(1)
        ReDim Preserve ARR_Extract(1 To n, 1 To i)    
        ARR_Extract(n, i) = WS(1).Cells(n, i).Value
    Next i
Next n

WEA.ScreenUpdating = True
WEA.DisplayAlerts = True
End Sub

Private Function LastColumn_FA(WSF As Excel.Worksheet, ifun&)
With WSF
LastColumn_FA = .Cells(ifun, .Columns.Count).End(xlToLeft).Column
End With
End Function

Private Function LastRow_FA(WSF As Excel.Worksheet, ifun&)
With WSF
LastRow_FA = .Cells(.Rows.Count, ifun).End(xlUp).Row
End With
End Function

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
End

Dim WE As Excel.Workbook
Dim WS As Excel.Worksheet
Dim r1 As Range
Dim r2 As Range
Dim myMultiAreaRange As Range

Sub Proverka()

Set WE = Application.Workbooks("Диаграмма.xlsb")
Set WS = WE.Worksheets("Лист1")

With WS

Set r1 = .Range(.Cells(1, 1), .Cells(13, 2))
Set r2 = .Range(.Cells(1, 4), .Cells(13, 4))
Set myMultiAreaRange = Union(r1, r2)
myMultiAreaRange.Select
.Shapes.AddChart.Select
ActiveChart.ChartType = xlLine
ActiveChart.SetSourceData myMultiAreaRange

End With

End Sub

Public Sub Proverka()

Set WE = Application.Workbooks("Диапазон.xlsm")
Set WS = WE.Worksheets("Лист1")

With WS

.Range(.Cells(1, 1), .Cells(13, 2)).Select 'работает

'.Range("A1:B13,D1:D14").Select 'работает
'.Range(.Cells(1, 1), .Cells(13, 2), .Cells(1, 4), .Cells(13, 4)).Select 'не работает

End With

End Sub

=СУММПРОИЗВ($C$2:$C$14*ЕЧИCЛО(ПОИСКПОЗ($A$2:$A$14;'Проверка номенклатуры'!$A$2:$A$7))*ЕЧИСЛО(ПОИСКПОЗ('Проверка номенклатуры'!$B$2:$B$7;"да")))

For n = 2 To Lt(1)
    oDict.Add Key:=WS(1).Cells(n, 1).Value, Item:=WS(2).Cells(n, 2).Value
    For i = Lt(2) To 2 Step -1
        If WS(2).Cells(i, 1).Value = oDict.Key(WS(1).Cells(n, 1).Value) & _
        oDict.Item(WS(1).Cells(n, 1).Value) = "Нет" Then WS(2).Rows(i).Delete
Next i: Next n 

Private Sub CommandButton1_Click()
y = 0

For Each Flag In Controls
    If Flag.Value = True Then
        nst(y) = Flag.Caption: y = y + 1
        ReDim Preserve nst(y): Debug.Print nst(y)
    End If
Next

End Sub
 

For i = 1 To 5
      CheckBox(i).Value = 1
Next i 

Dim WEP As Excel.Workbook
Dim WSP As Excel.Worksheet
Dim i&, m$
Dim n(2 To 3) As String


Public Sub Prostanovkaformul()

Set WEP = Application.Workbooks("Программный ввод формулы.xls")
Set WSP = WEP.Worksheets(1)

n(2) = "Магазин 1"
n(3) = "Магазин 2"

m = "апельсины"

For i = 2 To 3
    WSP.Cells(i, 4).Value = "=SUMIFS(RC[-1]:R[7]C[-1],RC[-3]:R[7]C[-3]," & "n(i)" & ",RC[-2]:R[7]C[-2]," & "m" & ")"
Next i

End Sub