sql - Vba to move duplicated rows from one sheet to another -

i looking code move duplicated rows 1 sheet sheet, trying sql query not getting how move values sheet.

much appreciated help.

i think want.

https://www.rondebruin.nl/win/s3/win006_4.htm

the range code example below looks column : header in a1 = country, a2:a? = country names column b : header in b1 = name, b2:b? = names column c : header in c1 = gender, c2:c? = f or m column d : header in d1 = birthday, d2:d? = dates    sub copy_to_worksheets() 'note: macro use function lastrow     dim my_range range     dim fieldnum long     dim calcmode long     dim viewmode long     dim ws2 worksheet     dim lrow long     dim cell range     dim ccount long     dim wsnew worksheet     dim errnum long      'set filter range on activesheet: a1 top left cell of filter range     'and header of first column, d last column in filter range.     'you can add sheet name code :     'worksheets("sheet1").range("a1:d" & lastrow(worksheets("sheet1")))     'no need sheet active when run macro when use this.     set my_range = range("a1:d" & lastrow(activesheet))     my_range.parent.select      if activeworkbook.protectstructure = true or _        my_range.parent.protectcontents = true         msgbox "sorry, not working when workbook or worksheet protected", _                vbokonly, "copy new worksheet"         exit sub     end if      'this example filters on first column in range(change field if needed)     'in case range starts in field:=1 column a, 2 = column b, ......     fieldnum = 1      'turn off autofilter     my_range.parent.autofiltermode = false      'change screenupdating, calculation, enableevents, ....     application         calcmode = .calculation         .calculation = xlcalculationmanual         .screenupdating = false         .enableevents = false     end     viewmode = activewindow.view     activewindow.view = xlnormalview     activesheet.displaypagebreaks = false      'add worksheet copy unique list , add criteriarange     set ws2 = worksheets.add      ws2         'first copy unique data filter field ws2         my_range.columns(fieldnum).advancedfilter _                 action:=xlfiltercopy, _                 copytorange:=.range("a1"), unique:=true          'loop through unique list in ws2 , filter/copy new sheet         lrow = .cells(rows.count, "a").end(xlup).row         each cell in .range("a2:a" & lrow)              'filter range             my_range.autofilter field:=fieldnum, criteria1:="=" & _              replace(replace(replace(cell.value, "~", "~~"), "*", "~*"), "?", "~?")              'check if there no more 8192 areas(limit of areas)             ccount = 0             on error resume next             ccount = my_range.columns(1).specialcells(xlcelltypevisible) _                      .areas(1).cells.count             on error goto 0             if ccount = 0                 msgbox "there more 8192 areas value : " & cell.value _                      & vbnewline & "it not possible copy visible data." _                      & vbnewline & "tip: sort data before use macro.", _                        vbokonly, "split in worksheets"             else                 'add new worksheet                 set wsnew = worksheets.add(after:=sheets(sheets.count))                 on error resume next                 wsnew.name = cell.value                 if err.number > 0                     errnum = errnum + 1                     wsnew.name = "error_" & format(errnum, "0000")                     err.clear                 end if                 on error goto 0                  'copy visible data new worksheet                 my_range.specialcells(xlcelltypevisible).copy                 wsnew.range("a1")                     ' paste:=8 copy columnwidth in excel 2000 , higher                     ' remove line if use excel 97                     .pastespecial paste:=8                     .pastespecial xlpastevalues                     .pastespecial xlpasteformats                     application.cutcopymode = false                     .select                 end             end if              'show data in range             my_range.autofilter field:=fieldnum          next cell          'delete ws2 sheet         on error resume next         application.displayalerts = false         .delete         application.displayalerts = true         on error goto 0      end      'turn off autofilter     my_range.parent.autofiltermode = false      if errnum > 0         msgbox "rename every worksheet name start ""error_"" manually" _              & vbnewline & "there characters in name not allowed" _              & vbnewline & "in sheet name or worksheet exist."     end if      'restore screenupdating, calculation, enableevents, ....     my_range.parent.select     activewindow.view = viewmode     application         .screenupdating = true         .enableevents = true         .calculation = calcmode     end  end sub   function lastrow(sh worksheet)     on error resume next     lastrow = sh.cells.find(what:="*", _                             after:=sh.range("a1"), _                             lookat:=xlpart, _                             lookin:=xlvalues, _                             searchorder:=xlbyrows, _                             searchdirection:=xlprevious, _                             matchcase:=false).row     on error goto 0 end function