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!!!!
Macro to copy rows to another worksheet if a cell matches a specific format
-
Kwong -
August 12, 2018 at 9:46 PM -
Thread is marked as Resolved.
-
-
-
Code
Display MoreSub abc() Dim s1 As Worksheet, s2 As Worksheet Set s1 = Sheets("Sheet1") Set s2 = Sheets("Sheet2") Dim lr As Long, lr2 As Long Dim i As Long lr = s1.Range("J" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False For i = 2 To lr lr2 = s2.Range("J" & Rows.Count).End(xlUp).Row If s1.Range("J" & i) Like "###[-]###[-]#" Then s1.Range("J" & i).EntireRow.Copy s2.Range("A" & lr2 + 1).PasteSpecial xlPasteValues End If Next i Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "complete" End Sub
-
Thank you VERY MUCH for the quick answer.
I made a very silly mistake .... I actually wanted to copy the rows that failed to match the ###-###-# format instead of the rows matched, I'm really sorry.
I added "NOT" to the IF statement (below) and it's half-working: catching everything except the blank cells
If not (If s1.Range("J" & i) Like "###[-]###[-]#") Then
What am I missing?Again, thank you very much for the quick answer and my apology for my error in describing what I needed.
-
-
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.
-
-
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 buttonIf the issue continues, suggest you upload a sample workbook that is representative of your work for analysis
-
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!
-
Here is amended code based upon your sample file
Code
Display MoreSub 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
-
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". -
Here you go:
Code
Display MoreSub 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
-
-
OMG, you're totally amazing!!!!
Thank you VERY VERY VERY much! -
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 SubPrivate 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 SubPrivate 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 -
[USER="187530"]bhupeshmulik[/USER]
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
-
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. -
Try this
Code
Display MoreSub 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
-
-
Works really well, much faster, thank you!!
-
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.
-
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
Display MorePrivate 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
Participate now!
Don’t have an account yet? Register yourself now and be a part of our community!