VBA to extract certain records and paste on another tab

[csenor]

Hi Forum. I have a journal entries in a table. In cases of emergencies, a tipline might have to be created and someone is in charge of compiling all of the tips and deciding what priority they are. My table headers are as follows starting in row 5: TIME, PHONE, NAME, TIP, PRIORITY. I have 4 tabs: TipLog, Priority1, Priority2, and Priority3. I want to be able to categorize a record as Priority 1 and it automatically (or by way of a button) to look at the table, find the priority 1 records and copy them to the Priority1 tab, priority 2 records to Priority2 tab, and priority 3 records to Priority3 tab.

This is what I have so far. Am I on the right track?


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim TipLog As Worksheet
Dim Priority1 As Worksheet
Dim priority2 As Workshet
Dim Priority3 As Worksheet
Dim Finalrow As Object
Dim ORange As Range ' Output range
Dim CRange As Range ' Criteria range
Dim IRange As Range ' Input range

Set ORange = Cells(1, 5)
Set IRange = Range("A5").Resize(Finalrow, 5)


Finalrow = Cells(Rows.Count, 1).End(xlDown).Row

Worksheets("TipLog").Select
Range("j1:az1").EntireColumn.Delete

Set TipLog = ActiveSheet

IRange.AdvancedFilter Action:=xlFilterCopy, criteriarange:=1, _
copytorange:=Priority1

IRange.AdvancedFilter Action:=xlFilterCopy, crieriarange:=2, _
copytorange:=prioirty2

IRange.AdvancedFilter Action:=xlFilterCopy, crieriarange:=3, _
copytorange:=prioirty3
' copy table header along with data and paste in another tab
If Target.Column = 5 And Target.Row > 5 Then

Range

End Sub

 

[igold]

Hi csenor,

How about something like this. This assumes that there is a header row on each of the Priority tabs. Additionally, the code will clear the priority sheets each time it is run and rewrite them with current TipLog.

Please test code on a backup copy of your data. Changes made are not usually reversible.

Sub findPrio()


    Application.ScreenUpdating = False
    Dim wsTL As Worksheet: Set wsTL = Worksheets("TipLog")
    Dim wsP1 As Worksheet: Set wsP1 = Worksheets("Priority1")
    Dim wsP2 As Worksheet: Set wsP2 = Worksheets("Priority2")
    Dim wsP3 As Worksheet: Set wsP3 = Worksheets("Priority3")
    Dim logLrow As Long, p1Lrow As Long, p2Lrow As Long, p3Lrow As Long
    Dim i As Long
    Dim Prio As Integer
    
    'Select TipLog
    wsTL.Activate
    
    'Find last row of all worksheets
    logLrow = wsTL.Cells(Rows.Count, 1).End(xlUp).Row
    p1Lrow = wsP1.Cells(Rows.Count, 1).End(xlUp).Row
    p2Lrow = wsP2.Cells(Rows.Count, 1).End(xlUp).Row
    p3Lrow = wsP3.Cells(Rows.Count, 1).End(xlUp).Row
    
    'Wipe Priority Sheets Clean
    wsP1.Range("A2:E" & p1Lrow).ClearContents
    wsP2.Range("A2:E" & p2Lrow).ClearContents
    wsP3.Range("A2:E" & p3Lrow).ClearContents
    
    'Rewrite Priority Sheets With Current TipLog
    For i = 6 To logLrow
        Prio = Cells(i, 5)
        Select Case Prio
            Case Is = 1
                p1Lrow = wsP1.Cells(Rows.Count, 1).End(xlUp).Row
                wsTL.Range(Cells(i, 1), Cells(i, 5)).Copy wsP1.Range("A" & p1Lrow + 1)
            Case Is = 2
                p2Lrow = wsP2.Cells(Rows.Count, 1).End(xlUp).Row
                wsTL.Range(Cells(i, 1), Cells(i, 5)).Copy wsP2.Range("A" & p2Lrow + 1)
            Case Is = 3
                p3Lrow = wsP3.Cells(Rows.Count, 1).End(xlUp).Row
                wsTL.Range(Cells(i, 1), Cells(i, 5)).Copy wsP3.Range("A" & p3Lrow + 1)
            Case Else
                MsgBox "ERROR - The Priority Number In Row " & i & " On the TipLog Is Not 1, 2, or 3"
        End Select
    Next
    Application.ScreenUpdating = True
End Sub

HTH

igold

 

[csenor]

Thank you igold. This almost works. I ran the macro and the only detail is that I want to maintain column widths when it pastes. I also would like the values to either paste only values or create proper table formatting with alternating colors in it's new location. The macro, as it is right now, copies the color of the row and pastes it to the new location, sometimes creating two blue rows next to each other. Besides that, it works great. Thank you so much.

 

[csenor]

The header rows on the priority tabs gets deleted as well igold.

 

[igold]

Hi,

See if this is closer to what you are looking for... Please make sure to add the header rows back to the priority sheets before running...

Sub findPrio()


    Application.ScreenUpdating = False
    Dim wsTL As Worksheet: Set wsTL = Worksheets("TipLog")
    Dim wsP1 As Worksheet: Set wsP1 = Worksheets("Priority1")
    Dim wsP2 As Worksheet: Set wsP2 = Worksheets("Priority2")
    Dim wsP3 As Worksheet: Set wsP3 = Worksheets("Priority3")
    Dim rng1 As Range, rng2 As Range, rng3 As Range
    Dim logLrow As Long, p1Lrow As Long, p2Lrow As Long, p3Lrow As Long
    Dim i As Long
    Dim Prio As Integer
    
    'Select TipLog
    wsTL.Activate
    
    'Find last row of all worksheets
    logLrow = wsTL.Cells(Rows.Count, 1).End(xlUp).Row
    p1Lrow = wsP1.Cells(Rows.Count, 1).End(xlUp).Row
    p2Lrow = wsP2.Cells(Rows.Count, 1).End(xlUp).Row
    p3Lrow = wsP3.Cells(Rows.Count, 1).End(xlUp).Row
    
    'Check for existing tables. Delete or Create as needed.
    wsP1.Activate
    If ActiveSheet.ListObjects.Count = 0 Then
        Set rng1 = Range("A1").CurrentRegion
        ActiveSheet.ListObjects.Add(xlSrcRange, rng1, , xlYes).Name = "TableP1"
        ActiveSheet.ListObjects("TableP1").TableStyle = "TableStyleMedium2"
    End If
    If ActiveSheet.ListObjects("TableP1").ListRows.Count >= 1 Then
        ActiveSheet.ListObjects("TableP1").DataBodyRange.Delete
    End If
    
    wsP2.Activate
    If ActiveSheet.ListObjects.Count = 0 Then
        Set rng2 = Range("A1").CurrentRegion
        ActiveSheet.ListObjects.Add(xlSrcRange, rng2, , xlYes).Name = "TableP2"
        ActiveSheet.ListObjects("TableP2").TableStyle = "TableStyleMedium2"
    End If
    If ActiveSheet.ListObjects("TableP2").ListRows.Count >= 1 Then
        ActiveSheet.ListObjects("TableP2").DataBodyRange.Delete
    End If
    
    wsP3.Activate
    If ActiveSheet.ListObjects.Count = 0 Then
        Set rng3 = Range("A1").CurrentRegion
        ActiveSheet.ListObjects.Add(xlSrcRange, rng3, , xlYes).Name = "TableP3"
        ActiveSheet.ListObjects("TableP3").TableStyle = "TableStyleMedium2"
    End If
    If ActiveSheet.ListObjects("TableP3").ListRows.Count >= 1 Then
        ActiveSheet.ListObjects("TableP3").DataBodyRange.Delete
    End If
    
    wsTL.Activate
    
    'Rewrite Priority Sheets With Current TipLog
    For i = 6 To logLrow
        Prio = Cells(i, 5)
        Select Case Prio
            Case Is = 1
                wsP1.Activate
                ActiveSheet.ListObjects("TableP1").ListRows.Add AlwaysInsert:=True
                p1Lrow = wsP1.Cells(Rows.Count, 1).End(xlUp).Row
                wsTL.Activate
                wsTL.Range(Cells(i, 1), Cells(i, 5)).Copy wsP1.Range("A" & p1Lrow)
            Case Is = 2
                wsP2.Activate
                ActiveSheet.ListObjects("TableP2").ListRows.Add AlwaysInsert:=True
                p2Lrow = wsP2.Cells(Rows.Count, 1).End(xlUp).Row
                wsTL.Activate
                wsTL.Range(Cells(i, 1), Cells(i, 5)).Copy wsP2.Range("A" & p2Lrow)
            Case Is = 3
                wsP3.Activate
                ActiveSheet.ListObjects("TableP3").ListRows.Add AlwaysInsert:=True
                p3Lrow = wsP3.Cells(Rows.Count, 1).End(xlUp).Row
                wsTL.Activate
                wsTL.Range(Cells(i, 1), Cells(i, 5)).Copy wsP3.Range("A" & p3Lrow)
            Case Else
                MsgBox "ERROR - The Priority Number In Row " & i & " On the TipLog Is Not 1, 2, or 3"
        End Select
    Next
    
    wsP1.Select
    ActiveSheet.Columns.AutoFit
    wsP2.Select
    ActiveSheet.Columns.AutoFit
    wsP3.Select
    ActiveSheet.Columns.AutoFit
    wsTL.Activate
    Application.ScreenUpdating = True
End Sub

 

[csenor]

That revision worked great!!! I have one more request. If I want to assign someone to investigate each lead, I'd like to be able to assign someone to investigate the lead without the worksheet erasing it each time I run the macro. Can we limit the clear contents rule to columns A:E?

 

[igold]

Well I am glad we made progress!

I understand what you are saying. In my mind the way around this issue would be to add another column to the TipLog, (Call it "Logged" or something), that the code could write to. This way with every subsequent run of the code, it can look in the newly added column and if that row has been logged then skip that row. Otherwise every time you run the code you will create duplicate entries from the TipLog to the Priority Sheets.

I hope I explained that OK.

Regards,

igold

 

[csenor]

I understand. Thanks so much for your help.

 

[igold]

Glad to help, thanks for the feedback.

If you need help implementing the "Logged" portion, let me know...

igold