If cell contains than copy...

[emukiss10]

Hello!

I'd like to have a macro that copy entire row to new Sheet at the end with name that I will choose if :

Cell in column H contains numbers 3 or 4 and cell in column Q has value less than 100% (for example 50% or 99%).

Please help kind experts!

Best Regards
W.

 

[Truiz]

The following code has an "Issue" you can only run it once because everytime it runs it asks to create a new sheet and asks for the name of the new sheet I wrote it like that because you mentioned " with name that I will choose" so here is the code

Change stuff in red to match your own

Sub icctc()
Dim lrow, lrow2, Yugi As Long
Dim Pokemon As String


Pokemon = Application.InputBox("[COLOR=#ff0000]Please Indicate name of new sheet[/COLOR]", "[COLOR=#ff0000]Sheet Name Selection[/COLOR]")
    Sheets.Add().Name = Pokemon
    
J = 1
For I = 1 To 17
    Cells(1, I).Value = "[COLOR=#ff0000]Header[/COLOR] " & J
    J = J + 1
Next

'Sheet1 refers to the sheet were the information is stored
    
lrow = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row


    For Yugi = lrow To 2 Step -1
    lrow2 = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
        Select Case Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Cells(Yugi, 8)
            Case "3", "4"
                If Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Cells(Yugi, 17).Value = 1 Then
                Sheets("[COLOR=#ff0000]Sheet1[/COLOR]").Rows(Yugi).Copy ActiveSheet.Rows(lrow2 + 1)
                End If
        End Select
    Next
End Sub

If your paste sheet already exist then you can use the below code and also fixes the issue with creating new tabs so you can run this code as needed

Sub icctc()
Dim lrow, lrow2, Yugi As Long
    
lrow = Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
lrow2 = Sheets("[COLOR=#ff0000]Your paste sheet[/COLOR]").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row


Sheets("[COLOR=#ff0000]Your paste sheet[/COLOR]").Range("A2:Z" & lrow2).ClearContents [COLOR=#008000]'We do this so that every time you run the code you dont have duplicate data[/COLOR]


    For Yugi = lrow To 2 Step -1
    lrow2 = Sheets("[COLOR=#ff0000]Your paste sheet[/COLOR]").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
        Select Case Cells(Yugi, 8)
            Case "3", "4"
                If Cells(Yugi, 17).Value = 1 Then
                Rows(Yugi).Copy Sheets("[COLOR=#ff0000]Your paste sheet[/COLOR]").Rows(lrow2 + 1)
                End If
        End Select
    Next
End Sub

 

[emukiss10]

Hello, thank you for the codes unfortunetly both of them does not work. Ive changed the way of creating new sheet. the rest is as follow. I have also set mothersheet as "sheets(1)" instead of full name of the sheet (it will always be the first one).

Sub Anew()

Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Next"

Dim lrow, lrow2, Yugi As Long
Dim Pokemon As String

j = 1
For i = 1 To 17
    Cells(1, i).Value = "Header " & j
    j = j + 1
Next

'Sheet1 refers to the sheet were the information is stored
    
lrow = Sheets(1).Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).row

    For Yugi = lrow To 2 Step -1
    lrow2 = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).row
        Select Case Sheets(1).Cells(Yugi, 8)
            Case "3", "4"
                If Sheets(1).Cells(Yugi, 17).Value = 1 Then
                Sheets(1).Rows(Yugi).Copy ActiveSheet.Rows(lrow2 + 1)
                End If
        End Select
    Next
End Sub

 

[emukiss10]

Effect is:

A1 to A17 all cell are named Header ​with different numbers and that is all it do

 

[Fluff]

Could you supply us with a sample of your data (say 10rows worth).
Methods of doing this can be found here
https://www.mrexcel.com/forum/about-board/508133-attachments.html

 

[emukiss10]

Im sorry, I cannot send any attachements or data because of security policy.

I have data in columns from A to AA of 'motherSheet'.

In column H i have different options in numbers and in column Q I have % of progress. I need to copy rows to new sheet (from motherSheet). The criteria are:

H = 3 or 4, Q < "100.0%"

Than I need to copy rows (from motherSheet) based on column J to yet another Sheet that has 9 or 14 characters in length.

Than I need to convert date in columns N and S (in motherSheet) from text format dd.mm.yyyy to date format yyyy-mm-dd

and there will be more but for now Im struggling with this problems..

Lots of things Fluff..

 

[Fluff]

Try this mod to your code

Sub Anew()

Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Next"

Dim lrow, lrow2, Yugi As Long
Dim Pokemon As String

j = 1
For i = 1 To 17
    Cells(1, i).Value = "Header " & j
    j = j + 1
Next

'Sheet1 refers to the sheet were the information is stored
    
lrow = Sheets(1).Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row

    For Yugi = lrow To 2 Step -1
    lrow2 = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
        Select Case Sheets(1).Cells(Yugi, 8)
            Case 3 To 4
                If Sheets(1).Cells(Yugi, 17).Value < 1 Then
                Sheets(1).Rows(Yugi).copy ActiveSheet.Rows(lrow2 + 1)
                End If
        End Select
    Next
End Sub

For your op

 

[emukiss10]

It creates "next" sheet and fill A1:A17 with Header1, Header2, Header3... and nothing more.

but I manage to bypass this spliting this macro in two smaller ones and it does the trick.

Sheets.Add(After:=Sheets(Sheets.Count)).Name = "XXX"

    Sheets(1).Select
    Rows("1:1").Select
    Selection.Copy
    Sheets("XXX").Select
    Rows("1:1").Select
    ActiveSheet.Paste
    Sheets(1).Select


Dim cell1 As Range
Dim lastRow1 As Long, i As Long


lastRow1 = Range("H" & Rows.Count).End(xlUp).row
i = 2


For Each cell1 In Sheets(1).Range("H1:H" & lastRow1)
    If cell1.Value = "3" Or cell1.Value = "4" Then
        cell1.EntireRow.Copy Sheets("XXX").Cells(i, 1)
        i = i + 1
    End If
Next
Worksheets("XXX").Columns("A:BB").AutoFit
    Range("A1").Select
'-----------------------------

Sheets("XXX").Select
Dim lrow As Long
Dim iCntr As Long
lrow = 200
For iCntr = lrow To 1 Step -1
If Cells(iCntr, 17) = "100.0%" Then
Rows(iCntr).Delete
End If
Next

now I need to

" copy rows (from motherSheet) based on column J to yet another Sheet that has 9 or 14 characters in length. "