Sub Внести()
    Dim shSrc As Worksheet, tblRes As ListObject, RowsCount As Long
    Dim fr As Long, lr As Long, i As Long
     
    Set shSrc = ActiveSheet
    Set tblRes = Worksheets("Продажа").ListObjects(1)
     
    For i = 9 To shSrc.Rows.Count
        If shSrc.Cells(i, "A").Value = "" Then
            lr = i - 1
            Exit For
        End If
    Next i
    If lr = 8 Then
        MsgBox "Нет данных!", vbExclamation
        Exit Sub
    End If
    
    fr = tblRes.ListRows.Count + 1
    RowsCount = lr - 9 + 1
    If tblRes.ListRows.Count = 0 Then
        tblRes.ListRows.Add
        RowsCount = RowsCount - 1
    End If
    If RowsCount <> 0 Then
        tblRes.ListRows(tblRes.ListRows.Count).Range.EntireRow.Offset(1).Resize(RowsCount).Insert
    End If
    shSrc.Range("A9:H" & lr).Copy
    tblRes.ListRows(fr).Range.Cells(1, 1).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End Sub

Sub Внести()
    Dim shSrc As Worksheet, tblRes As ListObject, RowsCount As Long
    Dim fr As Long, lr As Long, i As Long
    
    Set shSrc = ActiveSheet
    Set tblRes = Worksheets("Продажа").ListObjects(1)
    
    For i = 9 To shSrc.Rows.Count
        If shSrc.Cells(i, "A").Value = "" Then
            lr = i - 1
            Exit For
        End If
    Next i
    
    fr = tblRes.ListRows.Count + 1
    RowsCount = lr - 9 + 1
    If tblRes.ListRows.Count = 0 Then
        tblRes.ListRows.Add
        RowsCount = RowsCount - 1
    End If
    If RowsCount <> 0 Then
        tblRes.ListRows(tblRes.ListRows.Count).Range.EntireRow.Offset(1).Resize(RowsCount).Insert
    End If
    shSrc.Range("A9:H" & lr).Copy
    tblRes.ListRows(fr).Range.Cells(1, 1).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End Sub

Sub Транспонировать()
    Dim arrSrc(), arrRes()
    Dim r As Long, i As Long, j As Long
    
    arrSrc() = Range("A1").CurrentRegion.Value
    ReDim arrRes(1 To UBound(arrSrc, 1) * UBound(arrSrc, 2), 1 To 3)
    For i = 2 To UBound(arrSrc, 1)
        For j = 2 To UBound(arrSrc, 2)
            If arrSrc(i, j) <> "" Then
                r = r + 1
                arrRes(r, 1) = arrSrc(i, 1)
                arrRes(r, 2) = arrSrc(1, j)
                arrRes(r, 3) = arrSrc(i, j)
            End If
        Next j
    Next i
    Worksheets.Add After:=ActiveSheet
    Range("A1:C1").Value = Array("Дебитор", "Attribute", "Value")
    Range("A2").Resize(UBound(arrRes, 1), UBound(arrRes, 2)).Value = arrRes()
End Sub

Sub Скопировать_данные()
    Dim bkRes As Workbook, bkSrc As Workbook
    Dim shRes As Worksheet, strFilename As String
    Dim lngCalc As Long
    Dim i As Long, lr As Long
       
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Файлы Excel", "*.xlsm"
        If .Show = 0 Then
            Exit Sub
        End If
        strFilename = .SelectedItems(1)
    End With
       
    Application.ScreenUpdating = False
    lngCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
       
    Set bkRes = ActiveWorkbook
    Set bkSrc = Workbooks.Open(Filename:=strFilename, ReadOnly:=True)
       
    On Error Resume Next
    For i = 1 To bkRes.Worksheets.Count - 1
        Set shRes = bkRes.Worksheets(i)
        shRes.AutoFilter.ShowAllData
        lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
        If lr > 3 Then
            shRes.Range("A4:P" & lr).ClearContents
        End If
    Next i
    On Error GoTo 0
    
    Rub bkSrc, bkRes
    USD bkSrc, bkRes
       
    bkSrc.Close SaveChanges:=False
    Application.Calculation = lngCalc
    Application.ScreenUpdating = True
    MsgBox "Готово!", vbInformation
End Sub

Private Sub Rub(bkSrc As Workbook, bkRes As Workbook)
    Dim shSrc As Worksheet, arrSrc(), shRes As Worksheet
    Dim lr As Long, i As Long
    
    Set shSrc = bkSrc.Worksheets("despatches_RUB")
    On Error Resume Next
    shSrc.AutoFilter.ShowAllData
    On Error GoTo 0

    lr = shSrc.Cells(shSrc.Rows.Count, "E").End(xlUp).Row - 1
    arrSrc() = shSrc.Range("A1:R" & lr).Value
    For i = 4 To UBound(arrSrc)
        If arrSrc(i, 5) = "" Then
            Exit For
        End If
        If arrSrc(i, 18) <> 0 Then
            Set shRes = bkRes.Worksheets(arrSrc(i, 5))
            lr = shRes.Columns("A").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
                , SearchFormat:=False).Row + 1
            shRes.Range(shRes.Cells(lr, "A"), shRes.Cells(lr, "P")).Value = _
                shSrc.Range(shSrc.Cells(i, "C"), shSrc.Cells(i, "R")).Value
        End If
    Next i
End Sub

Private Sub USD(bkSrc As Workbook, bkRes As Workbook)
    Dim shSrc As Worksheet, arrSrc(), shRes As Worksheet
    Dim lr As Long, i As Long

    Set shSrc = bkSrc.Worksheets("SC_USD")
    On Error Resume Next
    shSrc.AutoFilter.ShowAllData
    On Error GoTo 0

    lr = shSrc.Cells(shSrc.Rows.Count, "D").End(xlUp).Row - 1
    arrSrc() = shSrc.Range("A1:P" & lr).Value
    For i = 4 To UBound(arrSrc)
        If arrSrc(i, 4) = "" Then
            Exit For
        End If
        If arrSrc(i, 16) <> 0 Then
            Set shRes = bkRes.Worksheets(arrSrc(i, 4))
            lr = shRes.Columns("A").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
                , SearchFormat:=False).Row + 1
            'Здесь допишите для остальных ячеек по аналогии. Сейчас сделано для двух ячеек.
            shRes.Cells(lr, "A").Value = shSrc.Cells(i, "B").Value
            shRes.Cells(lr, "B").Value = shSrc.Cells(i, "C").Value
        End If
    Next i
End Sub