Thread: Copy/paste code

Hi,

It seems to work fine for me with the two files you attached. The only reason I can see that would make the macro start at row 37 is if B36 of the relevant Warehouse sheet was non blank.

As an aside, it may be more appropriate to use Data Filter Advanced and filter the Delivery Status workbook using a Criteria where Status = "Arr" and Destination not blank, and have the data output fields in the same order as the Warehouse sheets. Then you could simply copy and paste the whole block in one go.

HTH

Hello Bob@Sun,

I revised your macro and it has been added to the attached workbook. You will need to change the source folder back to your own. Here is the macro code...

  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
  
    Set SrcWks = ThisWorkbook.ActiveSheet
    Set DataRng = SrcWks.Range("B5:AF29")
    
     'DstPath = "C:\Documents and Settings\bkostadinov\My Documents\project"
     DstPath = "C:\Documents and Settings\Admin.ADMINS\My Documents\Excel Forum Folders\Bob@Sun"
      
     '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
        Set DstWkb = Workbooks("Warehouse.xls")
       '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 & "Warehouse.xls")
           Err.Clear
        End If
      On Error GoTo 0
    
      R = Target.Row - DataRng.Row + 1
     
      Set DstWks = DstWkb.Worksheets(Target.Value)
      
     'Find the next empty row in the range "B3:B35"
      Set DstRng = DstWks.Range("B3:B34")
      Set RngEnd = DstRng.Cells(DstRng.Rows.Count, 1).End(xlUp)
      NR = IIf(RngEnd.Row < DstRng.Row, DstRng.Row, RngEnd.Row + 1)
      
      With DstWks
        .Cells(NR, "B").Value = DataRng.Cells(R, 1).Value
        .Cells(NR, "D").Value = DataRng.Cells(R, 2).Value
        .Cells(NR, "G").Value = DataRng.Cells(R, 5).Value
        .Cells(NR, "J").Value = DataRng.Cells(R, 7).Value
      End With
      
End Sub

Hi Bob@Sun
I've revised the definition of "LR" in your macro from this

 LR = DstWks.UsedRange.Rows.Count + 1

to this

LR = DstWks.Cells(1, 4).End(xlDown).Row + 1

such that it pastes data on the first blank row from the top of the range. However, in my mind, it appears to be pasting incorrect information in the wrong cells. But, again in my mind, your original procedure appears to do the same. So, you need to figure out this anomaly or let me know what should go where.
The line of code I changed assumes there is some entry in your merged cells "DEF", GHI", "JKLM" and NO" in the Warehouse worksheet. You'll see that I've added data there. If your "Real" worksheets have data in these cells, you should be good to go.
Another issue that probably needs addressed is that LR is based on column D of the warehouse you provided. This will probably not work in all warehouses. LR needs to know the last occupied row in each warehouse. Perhaps column A can be used for this purpose. I'd need to know more about your project to address this issue.
Again, the ONLY changes I made is the one line of code and populating the merged cells mentioned above.
Let me know if what's been provided works as expected. John

Originally Posted by Bob@Sun

Please Help!!!

Where's the bug. The only problem I can see is that the start of the xlup copy is row 45 which puts it below the last row of the warehouse sheet. Is that the bug to which you refer?

Rgds

Hi Bob@Sun
Try this code

Option Explicit
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 LR As Long

    Application.ScreenUpdating = False
    Set SrcWks = ThisWorkbook.ActiveSheet
    Set DataRng = SrcWks.Range("B5:AF29")

    'DstPath = "C:\Documents and Settings\bkostadinov\My Documents\project"
    DstPath = "C:\Documents and Settings\Bob@Sun\Desktop\New Folder\TEST"

    '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
    Set DstWkb = Workbooks("Warehouse.xls")
    '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 & "Warehouse.xls")
        Err.Clear
    End If
    On Error GoTo 0

    R = Target.Row - DataRng.Row + 1

    Set DstWks = DstWkb.Worksheets(Target.Value)
    Set DstRng = DstWks.Range("B:B")
    LR = DstWks.Range("B" & Rows.Count).End(xlUp).Row + 1


    DataRng.Cells(R, 1).Resize(1, 1).Copy
    DstRng.Cells(LR, 1).PasteSpecial Paste:=xlPasteValues
    DataRng.Cells(R, 2).Resize(1, 1).Copy
    DstRng.Cells(LR, 16).PasteSpecial Paste:=xlPasteValues
    DataRng.Cells(R, 5).Resize(1, 1).Copy
    DstRng.Cells(LR, 3).PasteSpecial Paste:=xlPasteValues
    DataRng.Cells(R, 7).Resize(1, 1).Copy
    DstRng.Cells(LR, 4).PasteSpecial Paste:=xlPasteValues
    DataRng.Cells(R, 9).Resize(1, 1).Copy
    DstRng.Cells(LR, 9).PasteSpecial Paste:=xlPasteValues
    Application.ScreenUpdating = True

End Sub

and see if it does what you're looking for.
John

Hi Bob@Sun
In looking at your code, it appears to be copying data from where it should to where it should. So, I can't help you with this issue

the code copies the informaiton the whole row in the Delivery status file is marked like is being copied and the whole role in the other file is selected

Regarding this issue

the screen is blinking on coping.

this code will fix that

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

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


End Sub

Of course, you may loose this

I like though the thing that the code focuses on the sheet where the information has been added.

unless you select the target sheet in the macro.
John