Results 1 to 3 of 3

Copy and paste to new workbook macro

Threaded View

  1. #1
    Registered User
    Join Date
    08-10-2011
    Location
    UK
    MS-Off Ver
    Excel 2003
    Posts
    2

    Copy and paste to new workbook macro

    Hi all,

    I have a macro in a template workbook (jobprogress) that once run, updates another workbook (summary) by adding the data to the next free line.

    However, A3 in 'jobprogress' is the project number. Everytime that particular 'jobprogress' is updated (by filling in different columns from B3 to Z3) it sends the data to 'summary' and I end up with multiple rows of the same project - not very useful for a summary sheet! Basically, I would like "before sending data, check if same project number exists in 'summary', if it does then delete that row and insert new data". Is this possible?

    Here is the code I have put together with the help of the internet!:
    Sub Copy_To_Another_Workbook()
    'START CHECK IF OPEN
        '===========================================
    'http://www.xcelfiles.com/IsFileOpenVBA.htm
    '===========================================
    
    '// Just change the file to test here
    Const strFileToOpen As String = "C:\Documents and Settings\user\Desktop\TEST\excel test\proj1\summary.xls"
        If IsFileOpen(strFileToOpen) Then
            MsgBox strFileToOpen & " is already Open" & _
                vbCrLf & "By " & LastUser(strFileToOpen), vbInformation, "File in Use"
        Else
            MsgBox strFileToOpen & " is not open", vbInformation
        End If
    End Sub
    Function IsFileOpen(strFullPathFileName As String) As Boolean
    '// VBA version to check if File is Open
    '// We can use this for ANY FILE not just Excel!
    '// Ivan F Moala
    '// http://www.xcelfiles.com
    Dim hdlFile As Long
        '// Error is generated if you try
        '// opening a File for ReadWrite lock >> MUST BE OPEN!
        On Error GoTo FileIsOpen:
        hdlFile = FreeFile
        Open strFullPathFileName For Random Access Read Write Lock Read Write As hdlFile
        IsFileOpen = False
        Close hdlFile
        Exit Function
    FileIsOpen:
        '// Someone has it open!
        IsFileOpen = True
        Close hdlFile
    End Function
    Private Function LastUser(strPath As String) As String
    '// Code by Helen from http://www.visualbasicforum.com/index.php?s=
    '// This routine gets the Username of the File In Use
    '// Credit goes to Helen for code & Mark for the idea
    '// Insomniac for xl97 inStrRev
    '// Amendment 25th June 2004 by IFM
    '// : Name changes will show old setting
    '// : you need to get the Len of the Name stored just before
    '// : the double Padded Nullstrings
    Dim strXl As String
    Dim strFlag1 As String, strflag2 As String
    Dim i As Integer, j As Integer
    Dim hdlFile As Long
    Dim lNameLen As Byte
    
    strFlag1 = Chr(0) & Chr(0)
    strflag2 = Chr(32) & Chr(32)
    hdlFile = FreeFile
    Open strPath For Binary As #hdlFile
        strXl = Space(LOF(hdlFile))
        Get 1, , strXl
    Close #hdlFile
    j = InStr(1, strXl, strflag2)
    #If Not VBA6 Then
        '// Xl97
        For i = j - 1 To 1 Step -1
            If Mid(strXl, i, 1) = Chr(0) Then Exit For
        Next
        i = i + 1
    #Else
        '// Xl2000+
        i = InStrRev(strXl, strFlag1, j) + Len(strFlag1)
    #End If
    '// IFM
    lNameLen = Asc(Mid(strXl, i - 3, 1))
    LastUser = Mid(strXl, i, lNameLen)
    'END CHECK IF OPEN
    
    'START COPY TO SUMMARY SHEET
        Dim SourceRange As Range
        Dim DestRange As Range
        Dim DestWB As Workbook
        Dim DestSh As Worksheet
        Dim Lr As Long
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        'Change the file name (2*) and the path/file name to your file
        If bIsBookOpen_RB("summary.xls") Then
            Set DestWB = Workbooks("summary.xls")
        Else
            Set DestWB = Workbooks.Open("C:\Documents and Settings\user\Desktop\TEST\excel test\proj1\summary.xls")
        End If
        'Change the Source Sheet and range
        Set SourceRange = ThisWorkbook.Sheets("Sheet1").Range("A3:Z3")
        'Change the sheet name of the database workbook
        Set DestSh = DestWB.Worksheets("Sheet1")
    
        Lr = LastRow(DestSh)
        Set DestRange = DestSh.Range("A" & Lr + 1)
        'We make DestRange the same size as SourceRange and use the Value
        'property to give DestRange the same values
        With SourceRange
            Set DestRange = DestRange.Resize(.Rows.Count, .Columns.Count)
        End With
        DestRange.Value = SourceRange.Value
        DestWB.Close savechanges:=True
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    'END COPY TO SUMMARY SHEET
    End Function
    and the function:

    Function bIsBookOpen_RB(ByRef szBookName As String) As Boolean
    ' Rob Bovey
        On Error Resume Next
        bIsBookOpen_RB = Not (Application.Workbooks(szBookName) Is Nothing)
    End Function
    Function LastRow(sh As Worksheet)
        On Error Resume Next
        LastRow = sh.Cells.Find(What:="*", _
                                After:=sh.Range("A1"), _
                                Lookat:=xlPart, _
                                LookIn:=xlFormulas, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious, _
                                MatchCase:=False).Row
        On Error GoTo 0
    End Function
    Any help would be greatly appreciated

    Threads also open:
    http://www.mrexcel.com/forum/showthread.php?t=569573 & http://www.ozgrid.com/forum/showthread.php?t=157022
    Last edited by knigget; 08-10-2011 at 08:16 AM. Reason: Cross post links added

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1