Announcement

Collapse
No announcement yet.

Macro to copy rows to another worksheet if a cell matches a specific format

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Macro to copy rows to another worksheet if a cell matches a specific format

    I have a worksheet1 containing multiple columns of data. I need a macro that checks only column "J" and if the data matches the format ###-###-# (e.g. 123-456-7), then copy that row to worksheet2. The cells in that column could be blank or could contain special characters (including wildcard characters). The number of rows in worksheet1 will be different each time when I apply this macro. Also, both worksheet1 and worksheet2 contain a header row (identical) and I want that header row remained in worksheet2.
    I'm new to macro's, any help would be much appreciated!!!!

  • apo
    replied
    HI.. Here's another one to try..

    It would be interesting to see which one is faster.. probably KJ's as although there is an extra loop.. it's all array based.

    Code:
    Private Sub CommandButton1_Click()
        Dim x, y, i As Long, strRows As String
        With Sheets("Combined").[A1].CurrentRegion
            x = .Value
            For i = LBound(x) To UBound(x)
                If Not x(i, 10) Like "###[-]###[-]#" Or x(i, 10) = "" _
                    Or x(i, 10) Like "[9]##[-]###[-]#" Then strRows = strRows & " " & i
            Next i
                   With Sheets("CheckAccts")
                        y = Application.Index(x, Split(Trim(strRows)), Evaluate("row(1:" & UBound(x, 2) & ")"))
                        .[A1].Resize(UBound(y, 2), UBound(y)) = Application.Transpose(y)
                        .Columns.AutoFit
                    End With
        End With
    End Sub

    Leave a comment:


  • KjBox
    replied
    You're welcome. You should find that there is very little increae in code runtime with your actual data of 10000+ rows, and the runtime will be a few of seconds as opposed to 10 mins with the previous code.

    Leave a comment:


  • Kwong
    replied
    Works really well, much faster, thank you!!

    Leave a comment:


  • KjBox
    replied
    Try this
    Code:
    Sub BadAccts2()
        Dim x, y, i As Long, ii As Long, iii As Long
        
        x = Sheets("Combined").Cells(1).CurrentRegion
        ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
        
        For i = 2 To UBound(x, 1)
            If Not x(i, 10) Like "###[-]###[-]#" Or x(i, 10) = "" _
            Or x(i, 10) Like "[9]##[-]###[-]#" Then
                iii = iii + 1
                For ii = 1 To UBound(x, 2)
                    y(iii, ii) = x(i, ii)
                Next
            End If
        Next
        With Sheets("CheckAccts")
            .Cells(1).CurrentRegion.Offset(1).Clear
            .[a2].Resize(UBound(y, 1), UBound(y, 2)) = y
            .Columns.AutoFit
            .Activate
        End With
        MsgBox "Possible invalid accounts, if any."
        
    End Sub

    Leave a comment:


  • Kwong
    replied
    Since I created the document with the above marco a few months ago, everything has been working except that I find it's taking longer and longer to finish running the macro as the data grow. The source document started with only about 100 records to now close to 10,000. It now takes me over 10 minutes waiting for the macro to complete (I have an older i5 processor). I wonder if there's a way to modify the macro to handle large amount of data more efficiently? Uploaded is a sample file with only about 1200 records, the real documents, again, have over 10,000 records.
    Thanks.
    Attached Files

    Leave a comment:


  • AlanSidman
    replied
    bhupeshmulik

    Your post does not comply with our Forum RULES. Use code tags around code.

    Posting code between tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

    Click on Edit to open your thread, then highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here

    Leave a comment:


  • bhupeshmulik
    replied
    Private Sub Admixtures_Click()
    If Admixtures.Value = True Then
    Row_Height = 14
    Else
    Row_Height = 0
    End If
    Row = 40
    For i = 0 To 10
    Worksheets("Task requisition").Rows(Row + i).RowHeight = Row_Height
    Next i
    End Sub

    Private Sub cementitious_material_Click()
    If cementitious_material.Value = True Then
    Row_Height = 14
    Else
    Row_Height = 0
    End If
    Row = 28
    For i = 0 To 10
    Worksheets("Task requisition").Rows(Row + i).RowHeight = Row_Height
    Next i
    End Sub

    Private Sub cements_Click()
    If cements.Value = True Then
    Row_Height = 14
    Else
    Row_Height = 0
    End If
    Row = 16
    For i = 0 To 10
    Worksheets("Task requisition").Rows(Row + i).RowHeight = Row_Height
    Next i
    End Sub

    Leave a comment:


  • Kwong
    replied
    OMG, you're totally amazing!!!!
    Thank you VERY VERY VERY much!

    Leave a comment:


  • AlanSidman
    replied
    Here you go:

    Code:
    Sub BadAccts()
        Dim s1 As Worksheet, s2 As Worksheet
        Set s1 = Sheets("Combined")
        Set s2 = Sheets("Results")
        Dim lr As Long, lr2 As Long
        Dim i As Long
        lr = s1.Range("A" & Rows.Count).End(xlUp).Row
        Application.ScreenUpdating = False
        For i = 2 To lr
            lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
            If Not s1.Range("J" & i) Like "###[-]###[-]#" Or s1.Range("J" & i) = "" Then
                s1.Range("J" & i).EntireRow.Copy
                s2.Range("A" & lr2 + 1).PasteSpecial xlPasteValues
            ElseIf s1.Range("J" & i) Like "[9]##[-]###[-]#" Then
                s1.Range("J" & i).EntireRow.Copy
                s2.Range("A" & lr2 + 1).PasteSpecial xlPasteValues
            End If
        Next i
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
        Sheets("Results").Select
        MsgBox "BadAccts"
    End Sub

    Leave a comment:


  • Kwong
    replied
    Hi Alan,
    This works perfectly, it picks up everything I wanted including blank cells. Thanks a million!
    It would be a bonus if you can somehow pick up the cells with a starting "9".

    Leave a comment:


  • AlanSidman
    replied
    Here is amended code based upon your sample file

    Code:
    Sub BadAccts()
        Dim s1 As Worksheet, s2 As Worksheet
        Set s1 = Sheets("Combined")
        Set s2 = Sheets("Results")
        Dim lr As Long, lr2 As Long
        Dim i As Long
        lr = s1.Range("A" & Rows.Count).End(xlUp).Row
        Application.ScreenUpdating = False
        For i = 2 To lr
            lr2 = s2.Range("A" & Rows.Count).End(xlUp).Row
            If Not s1.Range("J" & i) Like "###[-]###[-]#" Or s1.Range("J" & i) = "" Then
                s1.Range("J" & i).EntireRow.Copy
                s2.Range("A" & lr2 + 1).PasteSpecial xlPasteValues
            End If
        Next i
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
        Sheets("Results").Select
        MsgBox "BadAccts"
    End Sub
    I will look at your second half of your question tomorrow. Bed Time is here

    Leave a comment:


  • Kwong
    replied
    Hi Alan,

    I know I must have done something wrong but I just couldn't figured it out, therefore would appreciate if you wouldn't mind wasting a little more time on me.
    Uploaded is a sample file and the macro in question. It works perfectly in finding all the "wrong format" cells in column "J" and copes the respective row onto the "Results" tab. However, not the blank cells in the same column.
    By the way, if I want to find anything in column "J" that matches the format but starts with a "9" are also copied over to the results tab, would that be easily do-able?

    Thank you again for your time, much appreciated!
    Attached Files

    Leave a comment:


  • AlanSidman
    replied
    I have just tested with the changed line of code and it works perfectly for me. Check your formats.

    Also, install your code as follows.

    How to install your new code
    Copy the Excel VBA code
    Select the workbook in which you want to store the Excel VBA code
    Press Alt+F11 to open the Visual Basic Editor
    Choose Insert > Module
    Edit > Paste the macro into the module that appeared
    Close the VBEditor
    Save your workbook (Excel 2007+ select a macro-enabled file format, like *.xlsm)

    To run the Excel VBA code:
    Press Alt-F8 to open the macro list
    Select a macro in the list
    Click the Run button

    If the issue continues, suggest you upload a sample workbook that is representative of your work for analysis

    Leave a comment:


  • Kwong
    replied
    It's still not copying the rows and blank cells in column "J" (has data in most other columns). Maybe I need a separate statement or sub to get those?

    Thanks again.

    Leave a comment:

Working...
X