Sub Макрос1()

LastRow = Cells.SpecialCells(xlLastCell).Row
LastCol = Cells.SpecialCells(xlLastCell).Column
WB = ActiveWorkbook.Name 'присваиваем имя текущей книге
WB1 = "Новый файл.xlsm" 'присваиваем имя другой открытой книге, в которую надо перенести. "Новый файл@ - это имя уже открытой книги"
For i = 1 To LastRow
For j = 1 To LastCol
If Workbooks(WB).Sheets("Лист1").Cells(i, j).Value <> Empty Then
Workbooks(WB1).Sheets("Лист1").Cells(i, j).Value = Workbooks(WB).Sheets("Лист1").Cells(i, j).Value
End If
Next j
Next i

End Sub

Sub Get_All_File_from_SubFolders()
    Dim r As Range
    Dim FSO As Object, Folder As Object, File As Object
    Dim ws As Worksheet
    Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(sFolder)    'тут путь к своей папке
    For Each File In Folder.Files
        If InStr(File.Name, ".xls") > 0 Then
            Set ws = Workbooks.Open(File.Path).Sheets(1)
            Get_Current_Range ws
            ws.Parent.Close -1
        End If
    Next
    Set Folder = Nothing
    Set FSO = Nothing
    MsgBox "Готово!"
    Exit Sub
End Sub

Sub Get_Current_Range(f As Worksheet)
    Dim c As Range
    Dim i As Integer
    Dim j As Integer

    k = 0
    lLastRow = f.Cells.SpecialCells(xlLastCell).Row
    lLastCol = f.Cells.SpecialCells(xlLastCell).Column
    MsgBox "lLastRow=" & lLastRow & " lLastCol=" & lLastCol

    ReDim arrOfNumber(1, 0)
    For i = 1 To lLastRow
        For j = 1 To lLastCol
            If Len(f.Cells(i, j).Value) Then
                ReDim Preserve arrOfNumber(1, k)
                arrOfNumber(0, k) = i  'row
                arrOfNumber(1, k) = j  'colum
                k = k + 1
            End If
        Next j
    Next i
    k = k - 1
    MsgBox "Всего " & k
End Sub

Sub LastCell()
    Dim x As Range
    Set x = Cells.Find("*", [a1], xlFormulas, 1, 1, 2)
End Sub