how it is possible?

Dim Ws1, Ws2
Dim Wb1, wb2

Set Wb1 = ThisWorkbook 
Set wb2 = Workbooks("test1.xlsx") 

wb2.Worksheets("Sheet1").Range("A4").Copy Wb1.Worksheets("Sheet1").Range("B4")
wb2.Worksheets("Sheet1").Range("B10").Copy Wb1.Worksheets("Sheet1").Range("C4")
:
:
wbn.Worksheets("Sheet1").Range("An").Copy Wb1.Worksheets("Sheet1").Range("Bn")

CodePudding user response：

Retrieve Data From Closed Workbooks

Sub RetrieveDataFromClosedWorkbooks()
     
    ' Define constants.
     
    ' Source
    Const SOURCE_FOLDER_PATH As String = "C:\Test"
    Const SOURCE_FILE_PATTERN As String = "*.xlsx"
    Const SOURCE_WORKSHEET_NAME As String = "Sheet1"
    Const SOURCE_CELL_ADDRESSES As String = "A4,B10" ' add more
    ' Destination
    Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
    Const DESTINATION_FIRST_CELL_ADDRESS As String = "B4"
     
    ' Source
     
    Dim sFolderPath As String: sFolderPath = SOURCE_FOLDER_PATH
    If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
    
    Dim sFileName As String: sFileName = Dir(sFolderPath & SOURCE_FILE_PATTERN)
    If Len(sFileName) = 0 Then
        MsgBox "No files found.", vbExclamation
        Exit Sub
    End If
    
    Dim sAddresses() As String: sAddresses = Split(SOURCE_CELL_ADDRESSES, ",")
    Dim saUpper As Long: saUpper = UBound(sAddresses)
    
    ' Destination
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
    Dim dCell As Range: Set dCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
    
    ' Loop.
    
    Dim sa As Long
    
    Do Until Len(sFileName) = 0
        
        For sa = 0 To saUpper
            
            With dCell.Offset(sa)
                .Value = "='" & sFolderPath & "[" & sFileName & "]" _
                    & SOURCE_WORKSHEET_NAME & "'!" & sAddresses(sa)
                ' If you don't want to keep the formulas,
                ' uncomment the following line.
                '.Value = .Value
            End With
        
        Next sa
        
        Set dCell = dCell.Offset(, 1) ' next column
        
        sFileName = Dir ' next file
    Loop
    
    ' Inform.
    
    MsgBox "Data retrieved.", vbInformation
    
End Sub