Sub aaaaa()
Dim RR As Range, a&, b&, c&, t$, WB As Workbook, sh As Worksheet, tt$
On Error Resume Next
Set WB = Workbooks("base.xlsx")
tt = WB.Path 'путь для сохранения *csv файла
If Err Then Err.Clear: On Error GoTo 0: Exit Sub 'нет такой книги среди открытых
On Error GoTo 0
On Error Resume Next
Set sh = WB.Sheets("csvdate")
If Err Then Err.Clear: On Error GoTo 0: Exit Sub 'нет такого листа в книге
On Error GoTo 0
a = sh.UsedRange.Row
c = FreeFile
Open tt & "\" & "Test.csv" For Output As #c 'путь + имя файла с расширением
For b = a To a + sh.UsedRange.Rows.Count - 1
  t = vbNullString
  For Each RR In sh.UsedRange.Rows(b).Cells
    t = t & RR.Value & ";"
  Next
  Print #c, t
Next
Close #c

End Sub

Sheets(1).Cells(4,5).MergeArea.EntireRow

Sub aaaa()
Dim RR As Range, RR1 As Range, WBout As Workbook, WBin As Workbook, sh As Worksheet, a&, b&, c&, aa, x&, xx&
Set WBin = ThisWorkbook 'книга, из которой вызывается макрос, она-же приемник
Set WBout = Workbooks("пример_откуда.xlsx") 'книга-донор
aa = Array("а", "б") 'названия листов в обеих книгах)
For a = 0 To UBound(aa)
  With WBout.Sheets(aa(a)): b = .Cells(.Rows.Count, "C").End(xlUp).Row: End With
  With WBin.Sheets(aa(a)): c = .Cells(.Rows.Count, "C").End(xlUp).Row + 1: End With
  With WBout.Sheets(aa(a))
    x = 2
    Do While x <= b 'шерстим столбец "С" листа на наличие ячеек окрашенных желтым
      Do While .Cells(x, "C").Interior.Color <> vbYellow
        x = x + 1
      Loop
      If x > b Then Exit Do
      If RR Is Nothing Then
        Set RR = Intersect(.UsedRange, .Columns("C:D"), .Rows(x))
      Else: Set RR = Union(RR, Intersect(.UsedRange, .Columns("C:D"), .Rows(x)))
      End If
      x = x + 1
      Do While .Cells(x, "C").Interior.Color = vbYellow
        Set RR = Union(RR, Intersect(.UsedRange, .Columns("C:D"), .Rows(x)))
        x = x + 1
      Loop
    Loop
  End With
  If Not RR Is Nothing Then
    RR.Copy WBin.Sheets(aa(a)).Cells(c, "C"): Set RR = Nothing
  End If
Next

End Sub

psk = Worksheets("Таблица1").Cells(Worksheets("Таблица1").Rows.Count, "B").End(xlUp).Row

Public Меня_уже_Запускали
Sub НеВыпускают()
 Dim a(), b1, i
 a = Sheets("Калькуляция").[I75:I84].Value
 Меня_уже_Запускали = Меня_уже_Запускали Xor 1
 If Меня_уже_Запускали Xor 1 Then Exit Sub
 b1 = "не бывает"
 'Application.EnableEvents = False
 For i = 1 To UBound(a)
    If InStr(1, a(i, 1), b1, 1) Then
      MsgBox "Столешницы в выбранном сочетании не выпускают", vbExclamation, "Категория": Exit For
    End If
 Next
 'Application.EnableEvents = True
End Sub

sheets(1).[A2].Resize(ubound(myArray,1),ubound(myArray,2)).value=myArray