VBA copy filtered data with matching headers, go to sheet2, identify last row and paste each matching headers data in a new row below it

[Bellaanima7]

Hi Guys,

I am trying to copy filtered data with matching headers, go to sheet2, identify last row and paste each matching headers data in a new row below it, it doesn't work as expected. It copies all data and pastes it in order, does anyone know how to tweak the code to only paste matching headers that are not in order on SurveyDB sheet?

Private Sub Validation ()
'Move rows from FINAL worksheet that contain the word "New / Pending Validation" - column B
Worksheets("Final").Activate
With ActiveSheet
.AutoFilterMode = False
If Application.CountIf(.Range("B:B"), "*New / Pending Validation*") > 0 Then
    With Range("B1", Range("B" & Rows.Count).End(xlUp))
        .AutoFilter 1, "*New / Pending Validation*"
        .Offset(1).SpecialCells(12).EntireRow.copy
    End With
Else
    Beep
    MsgBox "New not found", vbInformation, "NO MATCH"
    Exit Sub
End If
'Go to SurveyDB worksheet and paste records in first available row
Worksheets("SurveyDB").Activate
Range("A1048576").Select
Selection.End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.Interior.Color = xlNone
Range("A1").Select
'Release copy mode from Final worksheet
Worksheets("Final").Activate
Application.CutCopyMode = False
' Undo Macro
    Sheets("Final").Select
    ActiveSheet.Range("$B$1:$B$958").AutoFilter Field:=1
End With
End Sub

 

[JLGWhiz]

Give this a try. Copy the code to a standard code module, not sheet module.

Sub Validation2() 'Private is not needed
Dim sh1 As Worksheet, sh2 As Worksheet, i As Long, fn As Range
Set sh1 = Sheets("Final")
Set sh2 = Sheets("Survey DB")
    With sh1
        If Application.CountIf(.Range("B:B"), "*New / Pending Validation*") > 0 Then
            .UsedRange.AutoFilter 2, "*New / Pending Validation*"
            For i = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
                Set fn = sh2.Rows(1).Find(.Cells(1, i).Value, , xlValues, xlWhole)
                    If Not fn Is Nothing Then
                        Intersect(.UsedRange.Offset(1), .Columns(i)).Copy
                        sh2.Cells(Rows.Count, fn.Column).End(xlUp)(2).PasteSpecial xlPasteAll
                        Application.CutCopyMode = False
                        Set fn = Nothing
                    End If
            Next
            .AutoFilterMode = False
        End If
    End With
End Sub

 

[Bellaanima7]

Hi,

It gives me error on ".UsedRange.AutoFilter 2, "*New / Pending Validation*"" -> "Autofilter method of range class failed"

Do you know how to repair it?

Thank you

 

[JLGWhiz]

I can't duplicate the error in test set up. Can you post an image of your worksheet so I can see what column B looks like? Otherwise, change

.UsedRange.AutoFilter 2, "*New / Pending Validation*"

to

Intersect(.UsedRange, .Columns(2)).AutoFilter 1, "*New / Pending Validation*"

and try that.

 

[Bellaanima7]

Good morning,

It works now, however there are some issues. Can I just paste values without the formulas to SurveyDB? What part of the code I should amend to do it?

It pastes data under correct header, but in the random rows based on the previously entered data (if there was blank entry it would paste data in the previous row etc.), not in the same line it started pasting the first column... can code be tweaked to start adding the rest of the header data in the same row it started in column A ie. Last entry starts in column A1855, can data from "Final" column B paste in B1855 too? not the next available that would be B1850?

Thank you

 

[Bellaanima7]

I have amended code so it pastes values now, can you kindly advise if we can somehow achieve pasting data in the same row, but still looking up at the headers?

Sub Validation2()
Dim sh1 As Worksheet, sh2 As Worksheet, i As Long, fn As Range
Set sh1 = Sheets("Final")
Set sh2 = Sheets("SurveyDB")
    With sh1
        If Application.CountIf(.Range("B:B"), "*New / Pending Validation*") > 0 Then
            Intersect(.UsedRange, .Columns(2)).AutoFilter 1, "*New / Pending Validation*"
            For i = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
                Set fn = sh2.Rows(1).Find(.Cells(1, i).Value, , xlValues, xlWhole)
                    If Not fn Is Nothing Then
                        Intersect(.UsedRange.Offset(1), .Columns(i)).copy
                        sh2.Cells(Rows.Count, fn.Column).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
                        Application.CutCopyMode = False
                        Set fn = Nothing
                    End If
            Next
            .AutoFilterMode = False
        End If
    End With
End Sub

 

[Bellaanima7]

I think I have managed to do it Can you kindly look at my below code and let me know if this is okay or if you can see any issues with my code? It works for me

Sub SurveyDBValidation()

Dim sh1 As Worksheet, sh2 As Worksheet, i As Long, fn As Range
Set sh1 = Sheets("Final")
Set sh2 = Sheets("SurveyDB")

    With sh1
    If Application.CountIf(.Range("B:B"), "*New / Pending Validation*") > 0 Then
    Intersect(.UsedRange, .Columns(2)).AutoFilter 1, "*New / Pending Validation*"
    For i = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
    Set fn = sh2.Rows(1).Find(.Cells(1, i).Value, , xlValues, xlWhole)
    If Not fn Is Nothing Then
    Intersect(.UsedRange.Offset(1), .Columns(i)).copy
    sh2.Cells(Rows.Count, fn.Column).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Set fn = Nothing
    End If
    Next
    .AutoFilterMode = False
    End If
    End With
    Sheets("SurveyDB").Select
    Columns("B:B").Select
    Selection.Replace What:="0", Replacement:="Validated", LookAt:= _
    xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Columns("Z:BA").Select
    Selection.NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
' NOBLANKS Macro
    Worksheets("SurveyDB").Activate
    With ActiveSheet
    .AutoFilterMode = False
    If Application.CountIf(.Range("B:B"), "*Validated*") > 0 Then
    With Range("B1", Range("B" & Rows.Count).End(xlUp))
    .AutoFilter 1, "*Validated*"
    .Offset(1).SpecialCells(12).EntireRow.Select
    Selection.Replace What:="", Replacement:="   ", LookAt:=xlWhole, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Sheets("SurveyDB").Select
    ActiveSheet.Range("$B$1:$B$958").AutoFilter Field:=1
    End With
    Else
    Beep
    MsgBox "New not found", vbInformation, "NO MATCH"
    Exit Sub
    End If
    End With
End Sub

 

[JLGWhiz]

Hi @Bellaanima7 - If you have the code working to your satisfaction then it is good. Glad you could work it out while I was off line.
Regards, JLG