Sub mrshkei2()
Dim rng As Range
Set rng = Selection
rng.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
End Sub

=ЕСЛИОШИБКА(ИНДЕКС($A5:$J5;АГРЕГАТ(15;6;СТОЛБЕЦ($A$5:$J$5)/($A5:$J5<>"");СТОЛБЕЦ(A$1)));"")

=СМЕЩ(Списки!$A$1;1;0;СЧЁТЕСЛИ(Списки!$A:$A;"<>"&"");1)

=СМЕЩ(Списки!$A$1;ПОИСКПОЗ($G$17;Списки!$A:$A;0)-1;1;СЧЁТЕСЛИ(Списки!A:A;$G$17);1)

=ЕСЛИОШИБКА(ТЕКСТ(ДЕНЬНЕД(A4;1);"дддд");"")

=СЧЁТЕСЛИМН($A:$A;F$1;$B:$B;"*"&$E2&"*")

Sub mrshkei()
Dim arr, i As Long, arr2, arr3, n As Long, col As New Collection, col2 As New Collection
LR = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A3:D" & LR)
For i = LBound(arr) + 1 To UBound(arr)
    On Error Resume Next
    col.Add arr(i, 1) & ":" & arr(i, 2), CStr(arr(i, 1) & ":" & arr(i, 2))
Next i

ReDim arr2(1 To col.Count, 1 To LR)
For i = 1 To col.Count
arr3 = Split(col(i), ":")
    arr2(i, 1) = arr3(0)
    arr2(i, 2) = arr3(1)
    k = 3
    For n = LBound(arr) + 1 To UBound(arr)
        If CStr(arr(n, 1)) = arr3(0) And arr(n, 2) = CDate(arr3(1)) Then
            arr2(i, k) = arr(n, 3)
            arr2(i, k + 1) = arr(n, 4)
            k = k + 2
        End If
    Next n
Next i
Range("F4").Resize(UBound(arr2), UBound(arr2, 2) - LBound(arr) + 1) = arr2
End Sub

Function myaddress(rng As Range) As String
Dim cell As Range
For Each cell In rng
    If cell = "Адрес организации" Then
        x1 = 1: GoTo XXX
    End If
    If x1 = 1 And cell <> 8 Then
        myaddress = myaddress & cell & vbLf
    ElseIf x1 = 1 And cell = 8 Then
         myaddress = Left(myaddress, Len(myaddress) - 1)
        Exit For
    End If
XXX:
Next cell
End Function

замените 
Worksheets("Лист1").Range("B2") = x
на
Worksheets("Лист1").Range("B2") = Left(x, Len(x) - 1)

Sub mrshkei()
Dim arr, i As Long, n as long lr As Long
With Worksheets("База")
lr = .Cells(Rows.Count, 1).End(xlUp).Row
arr = .Range("A1:A" & lr)
For i = LBound(arr) To UBound(arr)
    If arr(i, 1) = 7 Then
        For n = 1 To lr
            If arr(i + n, 1) <> 8 Then
            If arr(i + n, 1) <> "" Then
                x = x & arr(i + n, 1) & vbLf
            End If
            Else
                Worksheets("Лист1").Range("B2") = x
                Exit Sub
            End If
        Next n
    End If
Next i
End With
End Sub

Sub get_first_created()
Dim myPath$, mask$, f$, i%, t As Date
Dim myFolder As Object, myFile As Object
myPath = "C:\Users\123\Desktop\123\" ' директория для поиска
mask = "*.xlsx" ' маска поиска с * и ?
With CreateObject("Scripting.FileSystemObject")
    Set myFolder = .GetFolder(myPath)
    t = DateAdd("h", 9, Date) ' если ищем самый поздний - убрать эту строку
    For Each myFile In myFolder.Files
        If myFile.Name Like mask Then
            If CDate(myFile.DateCreated) > t Then  ' если ищем самый ранний, то  <, самый поздний  - >
                t = CDate(myFile.DateCreated)
                f = myFile.Name
            End If
        End If
    Next
End With
Workbooks.Open myPath & f
With ActiveWorkbook
    'часть кода которая берет нужные данные для отчета или что-то делает
    .Close SaveChanges:=False 'закрываем открытую книгу
End With
End Sub

t = Now ' если ищем самый поздний - убрать эту строку

t = DateAdd("h", 9, Date)

=--ПСТР(A6;ПОИСК(" - ";A6;1)+3;ПОИСК(" кг.";A6;1)-ПОИСК(" - ";A6;1)+3-6)

Sub mrshkei()
Dim arr, i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A1:C" & lr)
x1 = Range("F1"): x2 = Range("F2")
For i = LBound(arr) To UBound(arr)
    If arr(i, 1) = x1 And arr(i, 2) = x2 Then Range("H1") = arr(i, 3): Exit Sub
Next i
End Sub