cell range for an if statement

[spq24]

I am trying to set up a complicated macro.

basically i am running an if...then...else if statement and it loops through an entire column.

It's running through column T and there are cells that are populated and ones that are blank.

If the cell in column T is populated I wanted to copy the contents of cells in column A-S and paste it into a new sheet.

Example:
macro searches through the range and finds that cell T35 is populated. It copies A35-S35 in sheet 1 and it copies it and pastes it into sheet 2. and it will do this through out the loop whenever a cell in column T is populated.

Can anyone help?

 

[Dryver14]

Sub CopyAcross()
Dim i As Long
Dim LastRow As Long
Dim NextRow As Long
LastRow = Sheet1.Cells(Rows.Count, 20).End(xlUp).Row
NextRow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
Sheet1.Activate
    For i = 1 To LastRow
        If Cells(i, 20).Value <> "" Then
        Cells(i, 1).Resize(1, 19).Copy Sheet2.Cells(NextRow, 1)
        NextRow = NextRow + 1
        End If
    Next i
End Sub

 

[hiker95]

spq24,


See if this works for you without looping.


Sample worksheets before the macro:

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
1	Title A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
2	2	2	2	2	2	2	2	2	2	2	2	2	2	2	2	2	2	2	2
3	3	3	3	3	3	3	3	3	3	3	3	3	3	3	3	3	3	3	3	3
4	4	4	4	4	4	4	4	4	4	4	4	4	4	4	4	4	4	4	4
5	5	5	5	5	5	5	5	5	5	5	5	5	5	5	5	5	5	5	5	five
6	6	6	6	6	6	6	6	6	6	6	6	6	6	6	6	6	6	6	6
7	7	7	7	7	7	7	7	7	7	7	7	7	7	7	7	7	7	7	7	7
8	8	8	8	8	8	8	8	8	8	8	8	8	8	8	8	8	8	8	8
9	9	9	9	9	9	9	9	9	9	9	9	9	9	9	9	9	9	9	9	nine
10
Sheet1

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
1	Title A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
2
3
4
5
6
Sheet2

After the macro:

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
1	Title A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
2	3	3	3	3	3	3	3	3	3	3	3	3	3	3	3	3	3	3	3	3
3	5	5	5	5	5	5	5	5	5	5	5	5	5	5	5	5	5	5	5	five
4	7	7	7	7	7	7	7	7	7	7	7	7	7	7	7	7	7	7	7	7
5	9	9	9	9	9	9	9	9	9	9	9	9	9	9	9	9	9	9	9	nine
6
Sheet2

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub CopyRows()
' hiker95, 03/07/2011
' http://www.mrexcel.com/forum/showthread.php?t=533700
Dim LR As Long, NR As Long, RC As Long
Application.ScreenUpdating = False
With Worksheets("Sheet1")
  LR = .Cells(Rows.Count, 1).End(xlUp).Row
  .AutoFilterMode = False
  With .Range("A1:T" & LR)
    .AutoFilter Field:=20, Criteria1:="<>"
    NR = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    On Error Resume Next
    RC = 0
    RC = Application.Subtotal(103, .Range("T1:T" & LR)) - 1
    If RC > 1 Then
      .Range("A1").Offset(1).Resize(.Rows.Count - 1, 20).SpecialCells(12).Copy Worksheets("Sheet2").Range("A" & NR)
    End If
    On Error GoTo 0
    .AutoFilter
  End With
End With
Worksheets("Sheet2").Activate
Application.ScreenUpdating = True
End Sub

Then run the CopyRows macro.

 

[Dryver14]

Hiker,

I tested my macro and it works,

Your code, at this time, is beyond my capabilities but what is missing from mine to answer the original question.

I ask because I want to learn.

 

[spq24]

Awesome! worked perfectly Thanks I'll have more questions I'm sure as I get through this project so keep an eye out

 

[hiker95]

spq24,

You are very welcome.

Glad I could help.

Come back anytime.

 

[hiker95]

Dryver14,

Your code works, but it loops thru every cell in column T. If there was a huge amount of raw data, this could take a lot of time.

See the below code with comments of what it is doing.

Option Explicit
Sub CopyRows()
' hiker95, 03/07/2011
' http://www.mrexcel.com/forum/showthread.php?t=533700
Dim LR As Long, NR As Long, RC As Long

'Turn off screen flicker.  Code will run faster.
Application.ScreenUpdating = False
With Worksheets("Sheet1")
  
  'Find the last row in column A = 1
  LR = .Cells(Rows.Count, 1).End(xlUp).Row
  
  'If AutoFilter is already set, then turn AutoFilter off
  .AutoFilterMode = False
  
  With .Range("A1:T" & LR)
    
    'AutoFilter the range, Field 20 = column T, for cells that are not empty
    .AutoFilter Field:=20, Criteria1:="<>"
    
    'Find the next available row in Sheet2, column A
    NR = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    
    'The Subtotal 103 formula counts the visable rows of the filtered data
    'If there is an error with the Subtotal formula
    '  then RC RowsCount = 0
    '  then ignore the error
    On Error Resume Next
    RC = 0
    RC = Application.Subtotal(103, .Range("T1:T" & LR)) - 1
    
    'If RC RowsCount is greater than 1
    '  because the formula will count row 1 as 1
    '  then copy the visable rows to Sheet2
    If RC > 1 Then
      .Range("A1").Offset(1).Resize(.Rows.Count - 1, 20).SpecialCells(12).Copy Worksheets("Sheet2").Range("A" & NR)
    End If
    On Error GoTo 0
    
    'Turn off AutoFilter
    .AutoFilter
  End With
End With

'Activate, Select, the sheet where the data is being copied to
Worksheets("Sheet2").Activate
Application.ScreenUpdating = True
End Sub

 

[Dryver14]

Thanks for the explaination Hiker,

I will copy it into a module to study,

I think my problem is I have no concept of a large database,

In any job i've had the max in any row has been about 500

 

[spq24]

Sub CopyAcross()
Dim i As Long
Dim LastRow As Long
Dim NextRow As Long
LastRow = Sheet1.Cells(Rows.Count, 20).End(xlUp).Row
NextRow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
Sheet1.Activate
    For i = 1 To LastRow
        If Cells(i, 20).Value <> "" Then
        Cells(i, 1).Resize(1, 19).Copy Sheet2.Cells(NextRow, 1)
        NextRow = NextRow + 1
        End If
    Next i
End Sub

so it worked for what It to do for column t but now I need to do the same thing (individually into different sheets) for columns U through AE. I was just going to have it do it individually, and have that code run again referencing the different columns each time. When I did that it's saying "object required" what am I missing?

 

[spq24]

so it worked for what It to do for column t but now I need to do the same thing (individually into different sheets) for columns U through AE. I was just going to have it do it individually, and have that code run again referencing the different columns each time. When I did that it's saying "object required" what am I missing?

I think it may be because I was trying to name the sheet "sheet6" but it's actually sheet 10 while the code is referencing sheet 6. How can I have it reference a name?