(?<!/)/(?!/)

Sub main()
Dim arr, fact As Long, res(), s, t
' основная процедура
arr = Application.Transpose(Application.Transpose([A1:G1]))
t = Timer
s = permutations(arr, 1, res(), 1)
Debug.Print Timer - t
End Sub
Private Function swap(arr, a, b) As Variant
Dim s
' функция обмена переменными в массиве
s = arr(a)
arr(a) = arr(b)
arr(b) = s
swap = arr
End Function
Private Function permutations(arr, j, res(), k) As Variant
Dim i
' функция генерации перестановок
If j = UBound(arr) Then
    ReDim Preserve res(1 To k)
    res(k) = Join(arr, " ")
    k = k + 1
Else
    For i = j To UBound(arr)
        arr = swap(arr, j, i)
        permutations = permutations(arr, j + 1, res(), k)
        arr = swap(arr, j, i)
    Next i
End If
permutations = res
End Function

Sub Update_table()
Dim myConnect As Object, mySQL As String, myRecord As Object
Dim DataRange As String, strAddress As String, wshTarget As Worksheet
    strAddress = ActiveWorkbook.Sheets(1).Cells(1, 1).CurrentRegion.Address(0, 0)
    DataRange = "'" & ActiveWorkbook.FullName & "'.'" & ActiveWorkbook.Sheets(1).Name & "$'"
    Set myRecord = CreateObject("ADODB.Recordset")
    Set myConnect = CreateObject("ADODB.Connection")
    myConnect.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
           "Data Source=" & ThisWorkbook.Path & "\DB.xlsx;" & _
           "Extended Properties=""Excel 12.0;HDR=YES"""
    ' выбираем по критерию из книги DB.xlsx
    mySQL = "SELECT F2 FROM [Лист1$] WHERE [Data]=1"
    myRecord.Open mySQL, myConnect
    ' обновляем таблицу в книге с макросом
    mySQL = "UPDATE [" & ThisWorkbook.FullName & "].[Лист1$] SET F2=" & myRecord.Fields.Item(0).Value & " WHERE [Data]=1"
    myConnect.Execute mySQL
    
    myRecord.Close
    myConnect.Close
    
    Set myConnect = Nothing
    Set myRecord = Nothing
End Sub

' хотелось бы что-то такого: "UPDATE t_1 Set F2=(SELECT F2 FROM t2 WHERE [Data]=1) WHERE [Data=1]"

Sub Regulyarki()
Dim objRegexp As RegExp, myMatch As Match, colMatches   As MatchCollection
Dim i, k, myStr As String, CompStr As String, NewStr As String

Set objRegexp = New RegExp
objRegexp.Global = True
objRegexp.IgnoreCase = True
i = 1
myStr = CStr(Cells(1, 1))

While i < Len(myStr)
i = i + 1
    objRegexp.Pattern = "" & Mid(myStr, i, 1) & "(" _
                        & Mid(myStr, i, 1) & "){1,}"
            Set colMatches = objRegexp.Execute(myStr)
            For k = 0 To colMatches.Count - 1
                Set myMatch = colMatches.Item(k)
                CompStr = objRegexp.Replace(myMatch, myMatch.SubMatches(0))
                NewStr = Replace(myStr, myMatch, CompStr)
                myStr = NewStr
                Debug.Print NewStr
            Next k
            
Wend

Cells(2, 1) = myStr
End Sub

Set REdd = New RegExp:  REdd.Global = True: REdd.Pattern = "([A-Za-zЁёА-я])(?:\1)+"
If REdd.test(vl) Then vl = REdd.Replace(vl, "$1")

    For i = LBound(Result, 1) To UBound(Result, 1)
        For k = LBound(Result, 2) To UBound(Result, 2)
            RowTarget = Result(i, k)
            Set RowTarget = RowTarget.Offset(0, 1)
        Next k
    Next i

Sub Пример()
Dim i, Counter, myArr
Dim Criterial, RowTarget As Range, Result
Criterial = Cells(7, 1)
Set RowTarget = Range("a10")
myArr = Range("h1:j5")
For i = LBound(myArr, 1) To UBound(myArr, 1)
    If myArr(i, 1) = Criterial Then
                Counter = Counter + 1
                If Counter = 1 Then
                    ReDim Result(0, 1)
                Else
                    ReDim Result(UBound(Result), UBound(Result) + 1)

                End If
                Result(UBound(Result), UBound(Result)) = myArr(i, 2)
                Result(UBound(Result), UBound(Result) + 1) = myArr(i, 3)
    End If
Next i
RowTarget.Resize(1, UBound(Result) + 1) = Result

End Sub