Excel VBA Course
Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

copy whole rows based on "û" wrong tick in column

0

hi  experts 

I  want  copying  the  whole rows  contains mark  "û"  from sheet2 to result sheet , but  should  just  copy  wrong  tick based on column C for sheet2 

now   I  have  this  code  but  gives subsript  out  of  range  in  this  line 

.AutoFilter.Range.Offset(1).Copy Sheets(v(i, 1)).Cells(Sheets(v(i, 1)).Rows.Count, "A").End(xlUp).Offset(1)
Sub CopyRows()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, x As Long, srcWS As Worksheet
    Set srcWS = Sheets("Sheet2")
    v = srcWS.Range("C2", srcWS.Range("C" & srcWS.Rows.Count).End(xlUp)).Value
    With CreateObject("scripting.dictionary")
       For i = 1 To UBound(v)
          If Not .Exists(v(i, 1)) Then
             .Add v(i, 1), Nothing
             With srcWS
                If v(i, 1) = "û" And v(i, 1) < 0 Then
                    .Range("A2").CurrentRegion.AutoFilter 3, v(i, 1)
                    .AutoFilter.Range.Offset(1).Copy Sheets("result").Cells(Sheets("result").Rows.Count, "A").End(xlUp).Offset(1)

                Else
                    .Range("A2").CurrentRegion.AutoFilter 3, v(i, 1)
                    .AutoFilter.Range.Offset(1).Copy Sheets(v(i, 1)).Cells(Sheets(v(i, 1)).Rows.Count, "A").End(xlUp).Offset(1)
                End If
            End With
          End If
       Next i
    End With
    srcWS.Range("A2").AutoFilter
    Application.ScreenUpdating = True
End Sub

Answer
Discuss

Answers

0
Selected Answer

Leap

No need to use a dictionary here, just filtering is enough. Please try the attached file which includes the modified code below (commnets for guidance):

Sub CopyRows()
    Dim LstCl As Range, srcWS As Worksheet

    Set srcWS = Sheets("Sheet2")
    'turn off filtering if applied
    If srcWS.AutoFilterMode = True Then srcWS.AutoFilterMode = False

    Application.ScreenUpdating = False

    With srcWS.Range("A1")
        ' apply filter
        .CurrentRegion.AutoFilter 3, "=û"
        'ignore header row
        Set LstCl = srcWS.UsedRange.SpecialCells(xlCellTypeLastCell)
        'copy filtered result less header row to end of "results"
        With Sheets("result")
            srcWS.Range("A2", LstCl).SpecialCells(xlCellTypeVisible).Copy .Cells(.Cells(Sheets("result").Rows.Count, 1).End(xlUp).Row + 1, 1)
        End With
        .AutoFilter
    End With
    MsgBox "Copied"
    Application.ScreenUpdating = True
End Sub

Revision 03 March 2023:

Given you clarified that you want the "results" worksheet overwriting (rather than data added to the end), I've attached a second file where the macro is the same as above but the indented With section is replaced by this (changes in bold)

        With Sheets("result")
            .Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
            srcWS.Range("A2", LstCl).SpecialCells(xlCellTypeVisible).Copy .Cells(2, 1)
        End With

Hope this helps.

Discuss

Discussion

Hi john,
thanks  , but  unfortunately  the  error  still shows in  the  same  line.
leap (rep: 46) Mar 2, '23 at 2:10 pm
thanks  John  for  new  version works  very  well, just  I  want  clear   data  in result sheet  before  copy  data  . shouldn't copy  to  the  bottom  repeatedly .should  replace  data   , but  gives  error  object  required in this  line 
            srcWS.Range("A2", LstCl).SpecialCells(xlCellTypeVisible).Copy .Cells(.Cells(Sheets("result").Rows.Count, 1).End(xlUp).Row + 1, 1)

as  I  bold  line  waht  I  try  it
With Sheets("result").Cells(2, 2).CurrentRegion.ClearContents
leap (rep: 46) Mar 3, '23 at 7:33 am
Leap. Thanks for selecting my Answer.

Sorry I misunderstood that bit. I'm not on my PC but try:
With Sheets("result")
           .Cells(1,1).CurrentRegion.Offset(O, 1).ClearContents


(notice the added Offset so that the headings aren't cleared too) followed by:
            srcWS.Range("A2", LstCl).SpecialCells(xlCellTypeVisible).Copy .Cells(2,1)
John_Ru (rep: 6092) Mar 3, '23 at 8:58 am
thanks again 
unfortunatelly  your suggestion  doesn't  work and  clear header   and  continue copying  to  the  bottom  with  keep data have  laredy existed and  clear  some columns !
leap (rep: 46) Mar 3, '23 at 10:29 am
Apologies again, Leap (I shouldn't try to answer from my phone while playing with my granddaughter!).

I got the Offset wrong above. That With portion should read:
        With Sheets("result")
            .Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
            srcWS.Range("A2", LstCl).SpecialCells(xlCellTypeVisible).Copy .Cells(2, 1)
        End With


I'll revise my Answer to say that and to include a second file like that.
John_Ru (rep: 6092) Mar 3, '23 at 11:17 am
thanks  gain for  new updating 
leap (rep: 46) Mar 3, '23 at 12:31 pm
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login