Question : Re-write the script for Copy/Paste

Hi Experts,

I need to copy a workbook range ("D3:G7") and paste it in a deference workbook starts at column-E. I've attached the script and hope Expert could modify the script to make sure the paste starts at Column-E.

Hope you can help me.

Code Snippet:

         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:

           
           
             Sub Copy_Paste()

    Dim WB As Workbook
    Dim objFileDLG As Office.FileDialog
    Dim strFilePath, lnLoop, lnLineNo, lcTargetCell
    
    Set objFileDLG = Application.FileDialog(msoFileDialogFilePicker)
    lnLoop = 1
    lnLineNo = 2
    
    Do While lnLoop < 2
        With objFileDLG
            .Filters.Add "Excel Files", "*.xls", 1
            .FilterIndex = 1
            .AllowMultiSelect = False
            .Title = "Select The Workbook to copy From "
            If .Show() <> 0 Then
                strFilePath = .SelectedItems(1)
            End If
        End With
        
        Set WB = Workbooks.Open(strFilePath)
        WB.Activate
        WB.Worksheets(1).Range("D3:G7").Copy
        Select Case lnLoop
            Case 1
                lcTargetCell = "B2"
            Case 2
                lcTargetCell = "B7"
            Case 3
                lcTargetCell = "B12"
            Case 4
                lcTargetCell = "B16"
          
     
        End Select
        
        ThisWorkbook.Worksheets(1).Activate
        Range(lcTargetCell).Activate
        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
                   xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        lnLoop = lnLoop + 1
        WB.Close
        Set WB = Nothing
        
    Loop
End Sub

           
         

Open in New Window

Select All

Answer : Re-write the script for Copy/Paste

Try the following change and see if it is any better

Chris

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:

           
           
             Sub Copy_Paste()
Dim blnWasOpen As Boolean
    
    Dim wb As Workbook
    Dim objFileDLG As Office.FileDialog
    Dim strFilePath, lnLoop, lnLineNo, lcTargetCell
    Dim strTargetBook As String
        
    Set objFileDLG = Application.FileDialog(msoFileDialogFilePicker)
    lnLoop = 1
    lnLineNo = 2
        
    Do While lnLoop < 2
        With objFileDLG
            .Filters.Add "Excel Files", "*.xls", 1
            .FilterIndex = 1
            .AllowMultiSelect = False
            .Title = "Select The Workbook to copy From "
            If .Show() <> 0 Then
                strFilePath = .SelectedItems(1)
            End If
        End With
            
        Set wb = Workbooks.Open(strFilePath)
        wb.Activate
        wb.Worksheets(1).Range("D3:G7").Copy
        Select Case lnLoop
            Case 1
                lcTargetCell = "E2"
                strTargetBook = "Weekly Summary Report_Ellen.xls"
            Case 2
                lcTargetCell = "E7"
                strTargetBook = "Weekly Summary Report_Linda.xls"
            Case 3
                lcTargetCell = "E12"
                strTargetBook = "Weekly Summary Report_Theva.xls"
            Case 4
                lcTargetCell = "E16"
                strTargetBook = "Weekly Summary Report_Haze.xls"
         
        End Select
        If checkWB(strTargetBook) Then
            blnWasOpen = True
        Else
            Workbooks.Open Filename:=ThisWorkbook.Path & "\" & strTargetBook
            blnWasOpen = False
        End If
        wb.Activate
        wb.Worksheets(1).Range("D3:G7").Copy
        Windows(strTargetBook).Activate
        With ActiveWorkbook.Worksheets(1)
            .Activate
            .Range(lcTargetCell).Activate
            Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
                   xlNone, SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
        End With
        lnLoop = lnLoop + 1
        If Not blnWasOpen Then wb.Close
        Set wb = Nothing
            
    Loop
End Sub

Function checkWB(strPath As String)
Dim wb As Workbook
On Error Resume Next

    checkWB = False
    For Each wb In Application.Workbooks
        If LCase(wb.FullName) = LCase(strPath) Then
            checkWB = True
            Exit For
        End If
    Next

End Function
           
         

Open in New Window

Select All