rows contains certain text "?" in new document

[leewalker]

hi

i wonder if anyone can help me i have a spreadsheet with 12 columns

i am looking for a way in which i can search the whole spreadsheet row by row for "?" in the last columns and if found select the whole of the row and copy the whole row to a line of a spreadsheet of set name i require it to leave 1 row under each row it copies. until it get to the end of the spreadsheet around 4000+ lines.

as you can see if i was to do this manually would take hours upon hours.


i hope i have outlined my problem clearly if you have any more questions please do not hesitate to asked and i be happy to explain more best i can

i thank you all in advance.

 

[markmzz]

Hi Leewalker,

Try this small modification:

Sub CopyData()
    Dim Folderpath As String
    Dim r, x As Long
    Dim LastRow0, LastRow1, LastCol1, NextRow As Long
    Dim CWB, WBN, DWB As Workbook
    Dim mySheet0, mySheet2, mySheet1 As Worksheet
    Dim cell, c As Range
    
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual
    End With
    
    Set CWB = ActiveWorkbook
    Set mySheet0 = CWB.Sheets("Main")
    Folderpath = mySheet0.Range("B1").Value
    LastRow0 = mySheet0.Cells(Rows.Count, 2).End(xlUp).Row
    If Right(Folderpath, 1) <> "\" Then
      Folderpath = Folderpath & "\"
    End If
    
    Set WBN = Workbooks.Add(xlWBATWorksheet)
    Set mySheet1 = WBN.Worksheets(1)
    mySheet1.Name = "SheetCopiedData"
    For Each chkbx In mySheet0.CheckBoxes
        If chkbx.Value = 1 Then
            For r = 2 To LastRow0
                If Cells(r, 1).Top = chkbx.Top Then
                    Workbooks.Open Filename:=Folderpath & mySheet0.Range("B" & r).Value
                    Set DWB = ActiveWorkbook
                    Set mySheet2 = DWB.Sheets("sheet1")
                    LastRow1 = mySheet2.Cells(Rows.Count, 1).End(xlUp).Row
                    LastCol1 = mySheet2.Cells(1, Columns.Count).End(xlToLeft).Column
                    NextRow = mySheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    x = NextRow + IIf(NextRow = 2, -1, 1)
                    With mySheet1.Range("A" & x)
                        .Value = DWB.Path & " - " & DWB.Name
                        .Font.Bold = True
                        .Font.Color = -16776961
                    End With
                    x = x + 1
                    For Each c In mySheet2.Range(Cells(1, LastCol1).Address, _
                                    Cells(LastRow1, LastCol1).Address)
                        If InStr(c.Value, "?") Then
                            c.EntireRow.Copy mySheet1.Range("A" & x)
                            x = x + 2
                            Application.StatusBar = "Wait - Processing row number: " & x
                        End If
                    Next c
                    Exit For
                End If
            Next r
            DWB.Close SaveChanges:=False
        End If
    Next
    Application.StatusBar = False
    
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAuto
    End With
    WBN.Close SaveChanges:=True, Filename:="C:\Test\Copieddata"
End Sub

Markmzz

 

[Rick Rothstein]

    Dim Folderpath As String
    Dim r, x As Long
    Dim LastRow0, LastRow1, LastCol1, NextRow As Long
    Dim CWB, WBN, DWB As Workbook
    Dim mySheet0, mySheet2, mySheet1 As Worksheet
    Dim cell, c As Range

Unlike other languages, you must declare each variable's data type individually in VB, otherwise the variable will default to being a Variant. Using this line as an example...

Dim mySheet0, mySheet2, mySheet1 As Worksheet

Only the mySheet1 variable will be declared as a Worksheet whereas mySheet0 and mySheet2 will be declared as Variant. To do what you intended with this declaration, it would have to be written this way...

Dim mySheet0 As Worksheet, mySheet2 As Worksheet, mySheet1 As Worksheet

You would have to do similar (using the correct data type designation, of course) on the other Dim code lines where you have multiple variables declared.

 

[markmzz]

Unlike other languages, you must declare each variable's data type individually in VB, otherwise the variable will default to being a Variant.

Thanks Rick.

A small modification:

Sub CopyData()
    Dim Folderpath As String
    Dim r As Long, x As Long
    Dim LastRow0 As Long, LastRow1 As Long, LastCol1 As Long, NextRow As Long
    Dim CWB As Workbook, WBN As Workbook, DWB As Workbook
    Dim mySheet0 As Worksheet, mySheet2 As Worksheet, mySheet1 As Worksheet
    Dim cell As Range, c As Range
    
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual
    End With
    
    Set CWB = ActiveWorkbook
    Set mySheet0 = CWB.Sheets("Main")
    Folderpath = mySheet0.Range("B1").Value
    LastRow0 = mySheet0.Cells(Rows.Count, 2).End(xlUp).Row
    If Right(Folderpath, 1) <> "\" Then
      Folderpath = Folderpath & "\"
    End If
    
    Set WBN = Workbooks.Add(xlWBATWorksheet)
    Set mySheet1 = WBN.Worksheets(1)
    mySheet1.Name = "SheetCopiedData"
    For Each chkbx In mySheet0.CheckBoxes
        If chkbx.Value = 1 Then
            For r = 2 To LastRow0
                If Cells(r, 1).Top = chkbx.Top Then
                    Workbooks.Open Filename:=Folderpath & mySheet0.Range("B" & r).Value
                    Set DWB = ActiveWorkbook
                    Set mySheet2 = DWB.Sheets("sheet1")
                    LastRow1 = mySheet2.Cells(Rows.Count, 1).End(xlUp).Row
                    LastCol1 = mySheet2.Cells(1, Columns.Count).End(xlToLeft).Column
                    NextRow = mySheet1.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    x = NextRow + IIf(NextRow = 2, -1, 1)
                    With mySheet1.Range("A" & x)
                        .Value = DWB.Path & " - " & DWB.Name
                        .Font.Bold = True
                        .Font.Color = -16776961
                    End With
                    x = x + 1
                    For Each c In mySheet2.Range(Cells(1, LastCol1).Address, _
                                    Cells(LastRow1, LastCol1).Address)
                        If InStr(c.Value, "?") Then
                            c.EntireRow.Copy mySheet1.Range("A" & x)
                            x = x + 2
                            Application.StatusBar = "Wait - Processing row number: " & x
                        End If
                    Next c
                    Exit For
                End If
            Next r
            DWB.Close SaveChanges:=False
        End If
    Next
    Application.StatusBar = False
    
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAuto
    End With
    WBN.Close SaveChanges:=True, Filename:="C:\Test\Copieddata"
End Sub

Markmzz