Link to home
Start Free TrialLog in
Avatar of Kailey Lowe
Kailey Lowe

asked on

Move entire row to another pre-existing workbook based on cell value

I am sorting the status of a job as Loaded / Unloaded based on the text within the cell. What i need is to have a macro button installed which when pressed should read the cell value in  the status column and if it finds "Loaded" in column "S" then move the entire row to a different workbook (lets call it workbook2). Upon the transfer of the row of data it will delete from the current sheet. Workbook2 will have  two sheets for the sorted data - one for loaded and one for unloaded. An important feature of this code is that workbook2 already exists and therefore this macro will just need to open this notebook and save / close once the rows have been transferred.

My intent is to use this macro command button as an archive button to export the data from the current file to the next available row in  workbook2 (a pre-existing workbook).
ASKER CERTIFIED SOLUTION
Avatar of Martin Liss
Martin Liss
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
BTW I removed the ' Visual Basic Classic' (VB6) topic since I assumed that you didn't want the solution written in that language. If you do want a VB6 solution let me know and I'll put the topic back and rewrite my solution in that language.
Avatar of Kailey Lowe
Kailey Lowe

ASKER

Hi Martin! Thanks so much for your work on this. This workbook looks like it's going to work the way I would like it to! In addition to its current operation I would like the rows that have been archived to the new workbook to be removed from the first workbook
I'm sorry, I forgot about this. I see that you are using Excel on an Apple product. I have no experience with that but I'll see what I can do.
Try this little test program and tell me what happens.
Test.xlsm
No worries Martin, I appreciate you getting back to me!
I just altered your first code to add a loop to delete the rows that had been archived:
Here is what I came up with.. it seems to be working well!

Private Sub CommandButton1_Click()

Dim strArchiveWB As Variant
Dim lngNewRow As Long
Dim lngRow As Long
Dim wbArchive As Workbook
Dim wbSource As Workbook
Dim c As Range
Dim FirstAddress As String
Dim lngCount As Long

strArchiveWB = Application.GetOpenFilename(Title:="Please choose a file to import", FileFilter:="Excel Files *.xlsx (*.xlsx),")

If strArchiveWB = False Then
    MsgBox "No file specified.", vbExclamation, "GetShipment"
    Exit Sub
Else
    Application.ScreenUpdating = False
    Set wbSource = ThisWorkbook
    Set wbArchive = Workbooks.Open(strArchiveWB)

    With wbArchive.Sheets("Sheet1")
        If IsEmpty(.Range("A1")) Then
            lngNewRow = 0
        Else
            lngNewRow = .Range("A1048576").End(xlUp).Row
        End If
         
        With wbSource.Sheets("Schedule").Columns("S")
            Set c = .Find("LOADED", LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                FirstAddress = c.Address
                Do
                    lngNewRow = lngNewRow + 1
                    wbSource.Sheets("Schedule").Cells(c.Row, "A").EntireRow.Copy Destination:=wbArchive.Sheets("Sheet1").Cells(lngNewRow, "A")
                    lngCount = lngCount + 1
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> FirstAddress
               
                Application.DisplayAlerts = False
                wbArchive.Close SaveChanges:=True
                Application.DisplayAlerts = True
               
    Last = Cells(Rows.Count, "D").End(xlUp).Row
    For I = Last To 1 Step -1
        If (Cells(I, "S").Value) = "LOADED" Then
            Cells(I, "A").EntireRow.Delete
        End If
    Next I
               
                MsgBox "Archiving complete. " & lngCount & " rows archived."
            End If
        End With
    End With
End If

End Sub
I’m glad I was able to help.

If you expand the “Full Biography” section of my profile you’ll find links to some articles I’ve written that may interest you.

Marty - Microsoft MVP 2009 to 2017
              Experts Exchange Most Valuable Expert (MVE) 2015, 2017
              Experts Exchange Top Expert Visual Basic Classic 2012 to 2017
              Experts Exchange Top Expert VBA (current)