none
Challenging VBA Script to ManipulateTwo Workbooks RRS feed

  • Question

  • Good day VBA Gurus,

    I've been working on a VBA script which will enable me to manipulate data within two different workbooks.

    Details

    • Workbook1, Contains the main data.
    • Workbook2, consists of data that is to be pulled into Workbook1, as well as some unwanted data
    • The second column of Workbook2 has the last and first name of individuals, delimited by a comma and a space

    What I would like to accomplish using VBA Script placed in Workbook1 is as follows;

    1. Open Workbook2, Sheet1
    2. Split the last and first name in Workbook2, then
    3. Copy the last name in cell A2 of Workbook1 Sheet3
    4. Copy the first name in cell B2 of Workbook1 Sheet3
    5. Copy the data in cells D, I, J, F and E from Workbook2 to cells C to G (in this specific order from Workbook2 to Workbook1)
    6. Repeat until all the data in Workbook2, Sheet1 has been copied to Workbook1 Sheet3
    7. Close Workbook2
    8. Compare the data in cells A to G on Sheet3 of Workbook1, to the data in cells A to G on Sheet1 of Workbook1, then append only the new data in A to G from Sheet3 to Sheet1.
    9. Delete the data on Sheet3 in Workbook1
    10. Highlight the newly copied data in yellow. (First and Last name only)

    I'm an Excel VBA novice... many thanks for your assistance with this.


    • Edited by Davis TM Tuesday, November 3, 2015 7:56 PM
    Tuesday, November 3, 2015 7:51 PM

Answers

  • I'll absolutely make the post with the code as answer...

    The following is the code I worked on prior. This will executed when a change is made to the end date. Likely to be executed after the data transferred.

    Sub Shift()
    Dim r As Range, LR As Long, i As Long, ib As Long, mtch As Boolean, bmtch As Boolean
    With Sheets("Master_List")
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 3 To LR
            If .Range("J" & i).Value = "Off-Board" Then
                mtch = True
                Exit For
            End If
        Next i
        If Not mtch Then
            MsgBox "Nothing found", vbExclamation
            Exit Sub
        End If
        Set r = .Range("A3").Resize(LR - 1)
        .Range("A3").AutoFilter field:=10, Criteria1:="Off-Board"
        With r.SpecialCells(xlCellTypeVisible).EntireRow
            .Copy Destination:=Sheets("Off_Boarding").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets("Off_Boarding").Columns("A:K").AutoFit
            .Delete
        End With
        .Range("A3").AutoFilter
    End With
    With Sheets("Master_List")
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A3:J" & LR).Sort Key1:=.Range("A3"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End With
     
     With Sheets("Off_Boarding")
     OB = .Range("A" & Rows.Count).End(xlUp).Row
     For ib = 3 To OB
                If .Range("J" & ib).Value = "Off-Board" Then
                    bmtch = True
                    Exit For
                End If
                Next ib
                If Not bmtch Then
                MsgBox "No Data", vbExclamation
                Exit Sub
                End If
                .Range("A3:M" & ib).Borders(xlInsideHorizontal).LineStyle = xlContinuous
                .Range("A3:M" & ib).Borders(xlInsideVertical).LineStyle = xlContinuous
                .Range("A3:M" & ib).Borders(xlEdgeRight).LineStyle = xlContinuous
                .Range("A3:M" & ib).Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Range("A3:M" & ib).Borders(xlBottom).LineStyle = xlContinuous
     End With
    Application.EnableEvents = False
    End Sub


    Monday, November 9, 2015 5:57 PM

All replies

  • Dear Davis,

     

    I recommend you to record a macro, perform your tasks and then adapt the vba code you 'll obtain. It will help you a lot to understand vba. (see http://www.excelfunctions.net/Record-A-Macro.html if you don't know how to record a macro). I don't think that someone will write for you the vba code, this is not a "vba code market" but a forum, you should at least show us that you try by yourself first.

     

    Bests Regard,

    Wednesday, November 4, 2015 10:30 AM
  • All that can be done easier, we don't need Sheet3:

    Copy the code below into a regular code module of Workbook1.
    Open Workbook2 and active the source sheet
    Activate Workbook1 and active the dest sheet
    Run sub Main

    Andreas.

    Option Explicit
    
    Sub Main()
      Dim Data
      Dim i As Long, j As Long
      Dim Dest As Range
      
      'Copy the data from the other opened workbook
      Data = OtherWorkbook.ActiveSheet.UsedRange.Value
      If UBound(Data, 2) < 10 Then
        MsgBox "Not enough columns in source sheet!"
        Exit Sub
      End If
      
      For i = 1 To UBound(Data)
        'Split the last and first name
        j = InStr(Data(i, 1), ",")
        If j > 1 Then
          Data(i, 1) = Left$(Data(i, 2), j - 1)
          Data(i, 2) = Mid$(Data(i, 2), j + 1)
        Else
          Data(i, 1) = Data(i, 2)
          Data(i, 2) = ""
        End If
        'D, I, J, F and E to cells C to G
        Data(i, 3) = Data(i, 4)
        Data(i, 4) = Data(i, 9)
        Data(i, 5) = Data(i, 10)
        Data(i, 6) = Data(i, 6)
        Data(i, 7) = Data(i, 5)
      Next
      'Remove superflous columns
      ReDim Preserve Data(1 To UBound(Data), 1 To 7)
      'Find the next slot
      Set Dest = Range("A" & Rows.Count).End(xlUp).Offset(1)
      'Write the data into the sheet
      Dest.Resize(UBound(Data), UBound(Data, 2)).Value = Data
      'Color A:B of this data
      Dest.Resize(UBound(Data), 2).Interior.ColorIndex = 6
      'Remove duplicates
      Dest.CurrentRegion.RemoveDuplicates Array(1, 2)
    End Sub
    
    Private Function OtherWorkbook() As Workbook
      'Return the other opened workbook
      For Each OtherWorkbook In Workbooks
        'Skip the personal workbook, this is usual hidden
        If OtherWorkbook.Windows(1).Visible Then
          'Skip our own workbook
          If OtherWorkbook.Name <> ThisWorkbook.Name Then Exit Function
        End If
      Next
    End Function
    

    Wednesday, November 4, 2015 11:15 AM
  • Thanks for your feedback and recommendation Malick. I've attempted to write the code, and this post was my last resort. I acknowledge that this isn't a "VBA code market" and am simply seeking guidance from a community of more experienced coders whom are willing to do so. I recommend that in the future, if you misunderstand the request, start with a question instead of drawing conclusions that are incorrect...

    The following is what I've done thus far, after recently "diving" into VBA coding. Let me know your thoughts on this... There may be some ideas here for you as well. If you'd like, I can explain, in detail, to you what it does. I don't mind sharing at all...

    Sub Shift()
    Dim r As Range, LR As Long, i As Long, ib As Long, mtch As Boolean, bmtch As Boolean
    With Sheets("Master_List")
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 3 To LR
            If .Range("J" & i).Value = "Off-Board" Then
                mtch = True
                Exit For
            End If
        Next i
        If Not mtch Then
            MsgBox "Nothing found", vbExclamation
            Exit Sub
        End If
        Set r = .Range("A3").Resize(LR - 1)
        .Range("A3").AutoFilter field:=10, Criteria1:="Off-Board"
        With r.SpecialCells(xlCellTypeVisible).EntireRow
            .Copy Destination:=Sheets("Off_Boarding").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets("Off_Boarding").Columns("A:K").AutoFit
            .Delete
        End With
        .Range("A3").AutoFilter
    End With
    With Sheets("Master_List")
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A3:J" & LR).Sort Key1:=.Range("A3"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End With
     
     With Sheets("Off_Boarding")
     OB = .Range("A" & Rows.Count).End(xlUp).Row
     For ib = 3 To OB
                If .Range("J" & ib).Value = "Off-Board" Then
                    bmtch = True
                    Exit For
                End If
                Next ib
                If Not bmtch Then
                MsgBox "No Data", vbExclamation
                Exit Sub
                End If
                .Range("A3:M" & ib).Borders(xlInsideHorizontal).LineStyle = xlContinuous
                .Range("A3:M" & ib).Borders(xlInsideVertical).LineStyle = xlContinuous
                .Range("A3:M" & ib).Borders(xlEdgeRight).LineStyle = xlContinuous
                .Range("A3:M" & ib).Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Range("A3:M" & ib).Borders(xlBottom).LineStyle = xlContinuous
     End With
    Application.EnableEvents = False
    End Sub

    Wednesday, November 4, 2015 2:42 PM
  • Many Thanks Andreas. I'll merge this with my existing code, test it, and let you know the outcome.
    Wednesday, November 4, 2015 3:29 PM
  • Good day Andreas, I removed my code then copied the above code onto the the first sheet of Workbook1, then ran it. The following errors were observed.

    1. The Header from Workbook2 is copied to Workbook1 in next available row
    2. The full name in the second column of Workbook2 is being copied to column A of Workbook1 as opposed to being split between column A and B
    3. Column 5 in Workbook 1 is being copied to Column 7. The preference is to have column 5 from Workbook1 copied to column 7 in Workbook1
    4. It does not seem as though the duplicates on Wotkbook1's active sheet is being deleted
    5. I'm prompted with Run-time Error '1004'; Application-defined or Object-defined error. The debug highlights the following line; Dest.CurrentRegion.RemoveDuplicates Array(1, 2)

    Any recommendations?


    • Edited by Davis TM Wednesday, November 4, 2015 9:05 PM Added important information
    Wednesday, November 4, 2015 8:40 PM
  • Any recommendations?

    Upload 2 sample file on an online file hoster like www.dropbox.com and post the download link here.

    And I must know in which version(s) of Excel the macro should run.

    Andreas.

    Thursday, November 5, 2015 8:13 AM
  • Any recommendations?

    I've received your mail with the link to your sample files, just a few small adjustments, replace the Main macro with the code below.

    Andreas.

    Sub Main()
      Dim Data
      Dim i As Long, j As Long
      Dim Dest As Range
      
      'Copy the data from the other opened workbook
      With OtherWorkbook.ActiveSheet.UsedRange
        Data = .Offset(1).Resize(.Rows.Count - 1).Value
      End With
      If UBound(Data, 2) < 10 Then
        MsgBox "Not enough columns in source sheet!"
        Exit Sub
      End If
      
      For i = 1 To UBound(Data)
        'Split the last and first name
        j = InStr(Data(i, 2), ",")
        If j > 1 Then
          Data(i, 1) = Trim$(Left$(Data(i, 2), j - 1))
          Data(i, 2) = Trim$(Mid$(Data(i, 2), j + 1))
        Else
          Data(i, 1) = Data(i, 2)
          Data(i, 2) = ""
        End If
        'D, I, J, F and E to cells C to G
        Data(i, 3) = Data(i, 4)
        Data(i, 7) = Data(i, 5)
        Data(i, 4) = Data(i, 9)
        Data(i, 6) = Data(i, 6)
        Data(i, 5) = Data(i, 10)
      Next
      'Remove superflous columns
      ReDim Preserve Data(1 To UBound(Data), 1 To 7)
      'Find the next slot
      Set Dest = Range("A" & Rows.Count).End(xlUp).Offset(1)
      'Write the data into the sheet
      Dest.Resize(UBound(Data), UBound(Data, 2)).Value = Data
      'Color A:B of this data
      Dest.Resize(UBound(Data), 2).Interior.ColorIndex = 6
      'Remove duplicates
      Dest.CurrentRegion.Offset(1).RemoveDuplicates Array(1, 2), xlNo
      
      'Convert mail to hyperlink
      Set Dest = Range("G" & Rows.Count).End(xlUp)
      Do While Dest.Hyperlinks.Count = 0 And Dest.Row > 2
        Dest.Hyperlinks.Add Dest, "mailto:" & Dest.Value
        Set Dest = Dest.Offset(-1)
      Loop
    End Sub


    • Edited by Andreas Killer Saturday, November 7, 2015 9:52 AM
    • Proposed as answer by Davis.TM Monday, November 9, 2015 5:58 PM
    Saturday, November 7, 2015 9:50 AM
  • Thanks Andreas! The required columns are being transferred from the Source to the Master File. The only exception is that two of the last three existing records on Sheet 1 of the Master File are duplicated in the transfer process. Interestingly enough only the first two of the last three... Recommendations?

    P.S.

    For some reason I had to create a new profile here. The prior one doesn't allow me to responce to the post.

    Monday, November 9, 2015 4:00 PM
  • The only exception is that two of the last three existing records on Sheet 1 of the Master File are duplicated in the transfer process. Interestingly enough only the first two of the last three...

    No, that is not correct.

    The names in the existing data contains blanks, e.g. after the code has run you'll see that "Selter" is added. 3 rows up you can also see visually that name, but the cell contains "Selter ".

    And "Selter" <> "Selter ", that's the reason.

    Remove the blanks in the master file by Search&Replace, then run the code.

    Andreas.

    Monday, November 9, 2015 4:45 PM
  • Works perfectly! One million thanks. I assume my other code should be added a private sub, correct? The trigger is a change in the end date, i.e. sooner than 06/30/2016.

    Monday, November 9, 2015 5:23 PM
  • Works perfectly! One million thanks. I assume my other code should be added a private sub, correct?

    I don't know your code, but yes, call your sub after sub Main has run.

    I'm pleased to hear that it works.

    Would you please so kind and mark the post with the code as answer? So it would be easier to find the right answer for followers. Thank you.

    Andreas.

    Monday, November 9, 2015 5:40 PM
  • I'll absolutely make the post with the code as answer...

    The following is the code I worked on prior. This will executed when a change is made to the end date. Likely to be executed after the data transferred.

    Sub Shift()
    Dim r As Range, LR As Long, i As Long, ib As Long, mtch As Boolean, bmtch As Boolean
    With Sheets("Master_List")
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 3 To LR
            If .Range("J" & i).Value = "Off-Board" Then
                mtch = True
                Exit For
            End If
        Next i
        If Not mtch Then
            MsgBox "Nothing found", vbExclamation
            Exit Sub
        End If
        Set r = .Range("A3").Resize(LR - 1)
        .Range("A3").AutoFilter field:=10, Criteria1:="Off-Board"
        With r.SpecialCells(xlCellTypeVisible).EntireRow
            .Copy Destination:=Sheets("Off_Boarding").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets("Off_Boarding").Columns("A:K").AutoFit
            .Delete
        End With
        .Range("A3").AutoFilter
    End With
    With Sheets("Master_List")
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A3:J" & LR).Sort Key1:=.Range("A3"), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End With
     
     With Sheets("Off_Boarding")
     OB = .Range("A" & Rows.Count).End(xlUp).Row
     For ib = 3 To OB
                If .Range("J" & ib).Value = "Off-Board" Then
                    bmtch = True
                    Exit For
                End If
                Next ib
                If Not bmtch Then
                MsgBox "No Data", vbExclamation
                Exit Sub
                End If
                .Range("A3:M" & ib).Borders(xlInsideHorizontal).LineStyle = xlContinuous
                .Range("A3:M" & ib).Borders(xlInsideVertical).LineStyle = xlContinuous
                .Range("A3:M" & ib).Borders(xlEdgeRight).LineStyle = xlContinuous
                .Range("A3:M" & ib).Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Range("A3:M" & ib).Borders(xlBottom).LineStyle = xlContinuous
     End With
    Application.EnableEvents = False
    End Sub


    Monday, November 9, 2015 5:57 PM