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

New Member
Joined
Jul 23, 2020
Messages
22
Office Version
  1. 365
Platform
  1. Windows
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?

VBA Code:
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
 

Some videos you may like

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,519
Office Version
  1. 2013
Platform
  1. Windows
Give this a try. Copy the code to a standard code module, not sheet module.

VBA Code:
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

New Member
Joined
Jul 23, 2020
Messages
22
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Feb 7, 2012
Messages
12,519
Office Version
  1. 2013
Platform
  1. Windows
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
VBA Code:
.UsedRange.AutoFilter 2, "*New / Pending Validation*"
to
VBA Code:
Intersect(.UsedRange, .Columns(2)).AutoFilter 1, "*New / Pending Validation*"
and try that.
 

Bellaanima7

New Member
Joined
Jul 23, 2020
Messages
22
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

New Member
Joined
Jul 23, 2020
Messages
22
Office Version
  1. 365
Platform
  1. Windows
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?

VBA Code:
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

New Member
Joined
Jul 23, 2020
Messages
22
Office Version
  1. 365
Platform
  1. Windows
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 :)

VBA Code:
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

Well-known Member
Joined
Feb 7, 2012
Messages
12,519
Office Version
  1. 2013
Platform
  1. Windows
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
 

Watch MrExcel Video

Forum statistics

Threads
1,114,013
Messages
5,545,490
Members
410,686
Latest member
Fer9us
Top