1
\$\begingroup\$

I had been pondering a way to automate the creation of For Loops, specifically for copying rows from one sheet to another, based on a single criteria.

This script asks for the following information via a series of input boxes and prints a customized For Loop to the Immediate Window (which can then be pasted to a module):

  1. A column with a reliable last row to measure. In most of the data sets I see this is typically column 1, but I wanted to allow flexibility here.

  2. The criteria for copying rows to another sheet. For example, the presence of the word "thing to copy" in a row. This criteria must be in the same column for the row to be copied.

  3. The first row of data. While this is typically row 2, I wanted to offer flexibility here.

  4. The header row. While this is typically row 1, I wanted to offer flexibility here.

  5. The target sheet (where rows should be copied)

  6. The desired sub script name

The resulting For Loop comes out like this:

Sub ForLoopScript()

    Dim Source As Worksheet
    Dim Target As Worksheet

    Dim c As Range
    Dim CriteriaRange As Range
    Dim CriteriaString As String

    Set Source = Worksheets("source data")
    Set Target = Worksheets("target sheet")
    LastRow = Source.Cells(Rows.Count, 4).End(xlUp).Row

    With Source
        Set CriteriaRange = Source.Range(.Cells(2, 5), .Cells(LastRow, 5))
    End With

    j = 2
        For Each c In CriteriaRange
            CriteriaString = c.Text
                Select Case CriteriaString
                    Case Is = "thing to copy"
                        Source.Rows(c.Row).Copy Target.Rows(j)
    j = j + 1
                End Select
            Next c

   Source.Rows(1).Copy Target.Rows(1)

End Sub

I personally use this sort of For loop in most of my scripts, so I wanted to be able to customize these scripts quicker. Historically, I would just use a template I had saved as a text file, and customize it manually. Making this script has saved me time in this regard, and was also a fun challenge.

I thought I would post this here in the event anyone else finds it useful, or has critiques or suggestions for improvement. I'm curious to hear what the community thinks.

Option Explicit
Public Const vbDoubleQuote As String = """" 'represents 1 double quote (")

Sub ForLoopBuilder()

'source dims
    Dim SourceRange             As Range
    Dim Source                  As Worksheet
    Dim SourceString            As String
    Dim LastRowColumn           As Variant

'criteria dims
    Dim CriteriaRange           As Range
    Dim CriteriaString          As String
    Dim FirstRow                As Variant
    Dim HeaderRow               As Variant
    Dim CriteriaColumn          As Variant

 'target dims
    Dim TargetRange             As Range
    Dim Target                  As Worksheet
    Dim TargetString            As String

'debug dims
    Dim ScriptName              As String
    Dim RangeString             As String

'error handling
    On Error GoTo UserCancel

'capture source details
   Set SourceRange = Application.InputBox("Select column with last row to measure", Title:="1 Column Only", Type:=8)
   Set Source = SourceRange.Worksheet
   SourceString = Source.Name
   LastRowColumn = SourceRange.Column

'capture criteria details
    Set CriteriaRange = Application.InputBox("Select copy criteria", Title:="1 Cell Only", Type:=8)
    CriteriaString = CriteriaRange.Text
    FirstRow = Application.InputBox("First row of data?", "Enter number")
    HeaderRow = Application.InputBox("Header row?", "Enter number (0 if no header)")
    CriteriaColumn = CriteriaRange.Column

'capture target sheet details
    Set TargetRange = Application.InputBox("Select any cell in target sheet", Title:="1 Cell Only", Type:=8)
    Set Target = TargetRange.Worksheet
    TargetString = Target.Name

'capture sub name
    ScriptName = Application.InputBox("Enter script name", "Text Only")
    ScriptName = Replace(ScriptName, " ", "")

'saves criteria range as string
    RangeString = ".Range(.Cells(" & FirstRow & "," & CriteriaColumn & "),.Cells(" & "LastRow" & "," & CriteriaColumn & "))"

'prints dims to Immediate Window
    Debug.Print "Sub " & ScriptName & " ()" & vbNewLine
    Debug.Print vbTab & "Dim Source as Worksheet"
    Debug.Print vbTab & "Dim Target as Worksheet" & vbNewLine
    Debug.Print vbTab & "Dim c as Range"
    Debug.Print vbTab & "Dim CriteriaRange as Range"
    Debug.Print vbTab & "Dim CriteriaString as String" & vbNewLine
    Debug.Print vbTab & "Set Source = Worksheets(" & vbDoubleQuote & SourceString & vbDoubleQuote & ")"
    Debug.Print vbTab & "Set Target = Worksheets(" & vbDoubleQuote & TargetString & vbDoubleQuote & ")"
    Debug.Print vbTab & "LastRow = Source.Cells(Rows.Count," & LastRowColumn & ").End(xlUp).Row" & vbNewLine; ""

'print For Loop to Immediate Window
    Debug.Print vbTab & "With Source"
    Debug.Print vbTab & vbTab & "Set CriteriaRange = Source" & RangeString
    Debug.Print vbTab & "End With" & vbNewLine
    Debug.Print vbTab & "j = " & FirstRow
    Debug.Print vbTab & vbTab & "For Each c in CriteriaRange"
    Debug.Print vbTab & vbTab & vbTab & "CriteriaString = c.text"
    Debug.Print vbTab & vbTab & vbTab & vbTab & "Select Case CriteriaString "
    Debug.Print vbTab & vbTab & vbTab & vbTab & vbTab & "Case Is = " & vbDoubleQuote & CriteriaString & vbDoubleQuote
    Debug.Print vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & "Source.rows(c.row).copy Target.rows(j)"
    Debug.Print vbTab & "j = j + 1"
    Debug.Print vbTab & vbTab & vbTab & vbTab & "End Select"
    Debug.Print vbTab & vbTab & vbTab & "Next c" & vbNewLine
    Select Case HeaderRow
        Case Is <> 0
                Debug.Print vbTab & "Source.Rows(" & HeaderRow & ").copy Target.Rows(" & HeaderRow & ")" & vbNewLine
    End Select
    Debug.Print "End Sub"

'notify user
    MsgBox "See immediate window for your loop script!", vbInformation, ": )"

UserCancel:
End Sub

Update: for this task, I ended up settling on a method using AutoFilter:

Option Explicit
Public Const vbDoubleQuote As String = """" 'represents 1 double quote (")

Sub AutoFilterPro()

'source dims
    Dim SourceRange             As Range
    Dim Source                  As Worksheet
    Dim SourceString            As String

'criteria dims
    Dim CriteriaRange           As Range
    Dim CriteriaString          As String
    Dim CriteriaColumn          As Variant

 'target dims
    Dim TargetRange             As Range
    Dim Target                  As Worksheet
    Dim TargetString            As String

'debug dims
    Dim ScriptName              As String

'error handling
    On Error GoTo UserCancel

'capture criteria details
    Set CriteriaRange = Application.InputBox("Select copy criteria", Title:="1 Cell Only", Type:=8)
    CriteriaString = CriteriaRange.Text
    CriteriaColumn = CriteriaRange.Column
    Set Source = CriteriaRange.Worksheet
    SourceString = Source.Name

'capture target sheet details
    Set TargetRange = Application.InputBox("Select any cell in target sheet", Title:="1 Cell Only", Type:=8)
    Set Target = TargetRange.Worksheet
    TargetString = Target.Name

'capture sub name
    ScriptName = Application.InputBox("Enter script name", "Text Only")
    ScriptName = Replace(ScriptName, " ", "")

'prints dims to Immediate Window
    Debug.Print "Sub " & ScriptName & " ()"
    Debug.Print vbTab & "With Worksheets(" & vbDoubleQuote & SourceString & vbDoubleQuote & ").UsedRange"
    Debug.Print vbTab & vbTab & ".AutoFilter"
    Debug.Print vbTab & vbTab & ".AutoFilter Field:=" & CriteriaColumn & ", Criteria1:=" & vbDoubleQuote & "=" & CriteriaString & vbDoubleQuote
    Debug.Print vbTab & vbTab & ".Copy Worksheets(" & vbDoubleQuote & TargetString & vbDoubleQuote & ").Range(" & vbDoubleQuote & "A1" & vbDoubleQuote & ")"
    Debug.Print vbTab & vbTab & ".AutoFilter"
    Debug.Print vbTab & "End With"
    Debug.Print "End Sub"

'notify user
    MsgBox "See immediate window for your loop script!", vbInformation, ": )"

UserCancel:
End Sub

This produces the desired effect, but more efficiently (shown below):

Sub NewSub()
    With Worksheets("source data").UsedRange
        .AutoFilter
        .AutoFilter Field:=5, Criteria1:="=thing to copy"
        .Copy Worksheets("target sheet").Range("A1")
        .AutoFilter
    End With
End Sub
\$\endgroup\$
  • 1
    \$\begingroup\$ I'll give you this, it is an interesting idea to be able to accomplish this kind of task (especially if you can make it even more dynamic/able to handle more complex logic) but it also seems inefficient. You use a total of seven variables (two of which aren't declared, tsk tsk). Your worksheets variables aren't qualified (they implicitly rely on the ActiveWorkbook), and your copy method uses the inefficient Range copy (which can be a performance drain compared to using arrays). It is an interesting proof of concept, but I would argue that it would lead to copy-paste code. \$\endgroup\$ – Brandon Barney Jul 17 '17 at 18:16
  • \$\begingroup\$ @BrandonBarney Thanks Brandon, I appreciate you looking at this. I'll work to incorporate your feedback. \$\endgroup\$ – peter.domanico Jul 17 '17 at 18:23
  • \$\begingroup\$ Why would you write a code that creates a code for you to do sth? You can write a code that gets stuff from the user and does the same thing you wanted, or just make it in a way that it can recognize what it should do. \$\endgroup\$ – Ibo Jul 21 '17 at 3:47
  • \$\begingroup\$ @Ibo the whole point is to make sub routines quickly so they can be placed into a project. This is a development tool for me, not a tool for end users. \$\endgroup\$ – peter.domanico Jul 21 '17 at 20:23
  • \$\begingroup\$ @BrandonBarney relevant post, if you're interested:codereview.stackexchange.com/a/164621/138859 \$\endgroup\$ – peter.domanico Jul 22 '17 at 0:18

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.