Copy range of cells from one workbook to another-CodePudding

How can a range of cells be copied from one workbook to another? The code below does not work. I believe there is something wrong with how the range of cells are selected: sht1.Range("A1:D1").Select

Sub ImportData()

Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet

Application.ScreenUpdating = False

Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Open("C:\Users\Temp\Desktop\MyExcelSheet.xlsm")
Set sht1 = wkb1.Sheets("Data")
Set sht2 = wkb2.Sheets("Summary")

'Function to clear the existing data. Doesn't work.
sht1.Range("A1:D1").Select
sht1.Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents

' Copies data from the "Summary" sheet.
sht2.Range("O6:P102").Copy
sht2.Range("O6").Select
sht2.Range(Selection, Selection.End(xlToRight)).Select 
sht2.Range(Selection, Selection.End(xlDown)).Select 
Selection.Copy ' Copies all of the highlighted cells.

sht1.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False 
wkb2.Close True 
    
Application.ScreenUpdating = True
MsgBox "Complete"
End Sub

CodePudding user response：

Replace:

sht1.Range("A1:D1").Select
sht1.Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents

With

sht1.Range("A1:D" & Range("D1").End(xlDown).Row).Clear

Unless you specifically want to manually highlight the cells and then run the macro, this solution works.

This replacement code will now highlight every cell between "A1:D1" however, XlDown is only applied on the column "D".

CodePudding user response：

Copy the Values of a Range

Option Explicit

Sub ImportData()
    
    ' Source (open, read from & close)
    Const sFilePath As String = "C:\Users\Temp\Desktop\MyExcelSheet.xlsm"
    Const sName As String = "Summary"
    Const sFirstRowAddress As String = "O6:R6"
    ' Destination (write to & save)
    Const dName As String = "Data"
    Const dFirstCellAddress As String = "A1"
    
    ' Source
    
    Dim swb As Workbook: Set swb = Workbooks.Open(sFilePath)
    Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
    
    Dim srg As Range
     
    With sws.Range(sFirstRowAddress)
        Dim lCell As Range: Set lCell = .Resize(sws.Rows.Count - .Row   1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If lCell Is Nothing Then
            MsgBox "No data found.", vbCritical
            Exit Sub
        End If
        Set srg = .Resize(lCell.Row - .Row   1)
    End With
    
    ' Destination
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
    
    ' Clear & copy.
    With dws.Range(dFirstCellAddress).Resize(, srg.Columns.Count)
        ' Clear previous data.
        .Resize(dws.Rows.Count - .Row   1).Clear
        ' Copy values by assignment.
        .Resize(srg.Rows.Count).Value = srg.Value
    End With
    
    ' Save & close.
    swb.Close SaveChanges:=False
    'dwb.Save
    
    ' Inform.
    MsgBox "Values copied.", vbInformation
    
End Sub