Thread: Copy/paste code

Hi Bob@sun
This code

Sub CopyDeliveryData(Target As Range)

    Dim DataRng As Range
    Dim DstPath As String
    Dim DstRng As Range
    Dim DstWkb As Workbook
    Dim DstWks As Worksheet
    Dim NR As Long
    Dim R As Long
    Dim RngEnd As Range
    Dim SrcWks As Worksheet
    Dim DstWkbNm As String

'******************************
' Add This Line

    Application.ScreenUpdating = False
'******************************

    Set SrcWks = ThisWorkbook.ActiveSheet
    Set DataRng = SrcWks.Range("B6:BQ58")


    DstPath = "C:\Documents and Settings\Bob@Sun\Desktop\New Folder"

    'Make sure the folder path ends with a backslash
    DstPath = IIf(Right(DstPath, 1) <> "\", DstPath & "\", DstPath)

    On Error Resume Next
    'ignore potential error and resume execution on the next line of code

    Select Case Target.Value
    Case "Ester-Income"
        DstWkbNm = "Sklad-September09.xls"
    Case "Sofia-Income"
        DstWkbNm = "Sklad-September09.xls"
    Case "Kapelen-Income"
        DstWkbNm = "Sklad-September09.xls"
    Case "Drujba-Income"
        DstWkbNm = "Sklad-September09.xls"
    Case "Varna-Income"
        DstWkbNm = "Sklad-September09.xls"

    Case "IPK"
        DstWkbNm = "Zaiavka-September09.xls"
    Case "Standart"
        DstWkbNm = "Zaiavka-September09"
    Case "7 Dni"
        DstWkbNm = "Zaiavka-September09"
    Case "Drujba-Client"
        DstWkbNm = "Zaiavka-September09"
    Case "Ilinden 2000"
        DstWkbNm = "Zaiavka-September09"
    Case "IPK-Star Print"
        DstWkbNm = "Zaiavka-September09"
    Case "Maritsa"
        DstWkbNm = "Zaiavka-September09"
    Case "Kapelen-BG"
        DstWkbNm = "Zaiavka-September09"
    Case "Multiprint"
        DstWkbNm = "Zaiavka-September09"
    Case "Sega"
        DstWkbNm = "Zaiavka-September09"
    Case "Iconomedia"
        DstWkbNm = "Zaiavka-September09"
    Case "M Match"
        DstWkbNm = "Zaiavka-September09"

    End Select


    Set DstWkb = Workbooks(DstWkbNm)
    'this makes sure that if the workbook, worksheet does not exist, error 9 -Subscript Out of Range, it will creat it

    'the code below will creat the workbook if does not exist
    If Err = 9 Then
        Set DstWkb = Workbooks.Open(DstPath & DstWkbNm)
        Err.Clear
    End If

    On Error GoTo 0

    R = Target.Row - DataRng.Row + 1

    Set DstWks = DstWkb.Worksheets(Target.Value)
    Set DstRng = DstWks.Range("D:D")
    Set RngEnd = DstRng.Cells(DstRng.Rows.Count, 1).End(xlUp)
    NR = DstWks.Range("D" & Rows.Count).End(xlUp).Row + 1

    DataRng.Cells(R, 1).Resize(1, 1).Copy
    DstRng.Cells(NR, 1).PasteSpecial Paste:=xlPasteValues
    DataRng.Cells(R, 2).Resize(1, 1).Copy
    DstRng.Cells(NR, 67).PasteSpecial Paste:=xlPasteValues
    DataRng.Cells(R, 5).Resize(1, 64).Copy
    DstRng.Cells(NR, 2).PasteSpecial Paste:=xlPasteValues
    
    SendKeys "{ESC}", True
    DstWks.Activate
    DstRng.Cells(NR, 2).Select

'*************************************
'Change this line
    Application.ScreenUpdating = True
'*************************************


End Sub

should take care of both issues. Let me know. John

You're wecome. If satified, please mark your thread as solved.
John