Long VBA Code - Can it be reduced

N

Nm

Hi

I have created the following VBA code, all it does is to check if data
is present in a column (either A, B, C) and then copy it in a separate
sheet in the same file.

I am sure there must be a way to do it so that code is shorter than
what I have.

Please make suggestions as I cant comeup with anything right now.

Thanks,
Naeem
-------------------------------------------------

If Sheet1.Range("A1") = "YES" Then
Range("Data_1").Select
Selection.Copy
Sheets.Add
ActiveSheet.Name = Range("Sheet_Name_1")
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Columns.AutoFit
Sheet1.Select

If Sheet1.Range("B1") = "YES" Then
Range("Data_2").Select
Selection.Copy
Sheets.Add
ActiveSheet.Name = Range("Sheet_Name_2")
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Columns.AutoFit
Sheet1.Select

If Sheet1.Range("C1") = "YES" Then
Range("Data_3").Select
Selection.Copy
Sheets.Add
ActiveSheet.Name = Range("Sheet_Name_3")
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Columns.AutoFit
Sheets("Sheet1").Select
Range("H5").Select

Else
If Sheet1.Range("C1") = "YES" Then
Range("Data_3").Select
Selection.Copy
Sheets.Add
ActiveSheet.Name = Range("Sheet_Name_3")
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Columns.AutoFit
Sheets("Sheet1").Select
Range("H5").Select

End If
End If

Else

If Sheet1.Range("B1") = "YES" Then
Range("Data_2").Select
Selection.Copy
Sheets.Add
ActiveSheet.Name = Range("Sheet_Name_2")
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Columns.AutoFit
Sheet1.Select

If Sheet1.Range("C1") = "YES" Then
Range("Data_3").Select
Selection.Copy
Sheets.Add
ActiveSheet.Name = Range("Sheet_Name_3")
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Columns.AutoFit
Sheets("Sheet1").Select
Range("H5").Select

End If

Else

If Sheet1.Range("C1") = "YES" Then
Range("Data_3").Select
Selection.Copy
Sheets.Add
ActiveSheet.Name = Range("Sheet_Name_3")
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Columns.AutoFit
Sheets("Sheet1").Select
Range("H5").Select


End If
End If
End If
End If

End Sub
 
D

Dan R.

Naeem try this:

Sub Test()
For Each Cell In ActiveSheet.Range("A1:C1")
If Cell.Value = "YES" Then
Select Case Mid(Cell.Address, 2, 1)
Case Is = "A"
Set sh = ThisWorkbook.Worksheets.Add
sh.Name = Range("Sheet_Name_1")
Range("Data_1").Copy Sheets(Range( _
"Sheet_Name_1").Text).Range("A1")
Sheets(Range("Sheet_Name_1").Text).Columns("A").AutoFit
Case Is = "B"
Set sh = ThisWorkbook.Worksheets.Add
sh.Name = Range("Sheet_Name_2")
Range("Data_2").Copy Sheets(Range( _
"Sheet_Name_2").Text).Range("A1")
Sheets(Range("Sheet_Name_2").Text).Columns("A").AutoFit
Case Is = "C"
Set sh = ThisWorkbook.Worksheets.Add
sh.Name = Range("Sheet_Name_3")
Range("Data_3").Copy Sheets(Range( _
"Sheet_Name_3").Text).Range("A1")
Sheets(Range("Sheet_Name_3").Text).Columns("A").AutoFit
End Select
End If
Next Cell
End Sub
 
N

Nm

Naeem try this:

Sub Test()
For Each Cell In ActiveSheet.Range("A1:C1")
If Cell.Value = "YES" Then
Select Case Mid(Cell.Address, 2, 1)
Case Is = "A"
Set sh = ThisWorkbook.Worksheets.Add
sh.Name = Range("Sheet_Name_1")
Range("Data_1").Copy Sheets(Range( _
"Sheet_Name_1").Text).Range("A1")
Sheets(Range("Sheet_Name_1").Text).Columns("A").AutoFit
Case Is = "B"
Set sh = ThisWorkbook.Worksheets.Add
sh.Name = Range("Sheet_Name_2")
Range("Data_2").Copy Sheets(Range( _
"Sheet_Name_2").Text).Range("A1")
Sheets(Range("Sheet_Name_2").Text).Columns("A").AutoFit
Case Is = "C"
Set sh = ThisWorkbook.Worksheets.Add
sh.Name = Range("Sheet_Name_3")
Range("Data_3").Copy Sheets(Range( _
"Sheet_Name_3").Text).Range("A1")
Sheets(Range("Sheet_Name_3").Text).Columns("A").AutoFit
End Select
End If
Next Cell
End Sub
Click to expand...

Hi Dan,

I tried and it works..Wow its way shorter than what I have. I will go
through it and try to understand the code.

Thank you.

Naeem
 
D

Dan Thompson

You can use this code it is much shorter very simple but you said you wanted
to shorten so this is the shortest way to do it. That I can think of.

Sub CopyData()
Dim MyRange As Range
Dim cel As Range
Set MyRange = Worksheets("Sheet1").Range("A1:C500") 'You can change the
range to what ever you need it
For Each cel In MyRange
If Not cel.Value = "" Then
xVal = cel.Value
xaddress = cel.Address
Worksheets("Sheet2").Range(xaddress).Value = xVal
End If
Next cel
End Sub
 
N

Nm

You can use this code it is much shorter very simple but you said you wanted
to shorten so this is the shortest way to do it. That I can think of.

Sub CopyData()
Dim MyRange As Range
Dim cel As Range
Set MyRange = Worksheets("Sheet1").Range("A1:C500") 'You can change the
range to what ever you need it
For Each cel In MyRange
If Not cel.Value = "" Then
xVal = cel.Value
xaddress = cel.Address
Worksheets("Sheet2").Range(xaddress).Value = xVal
End If
Next cel
End Sub






- Show quoted text -
Click to expand...

Hi Dan,

I tried running this code and comeup with the following error.

Run-time error '9':
Subscript Out of Range

and it highlights the following

Worksheets("Sheet2").Range(xaddress).Value = xVal

In my file I have only 1 sheet and when I run the macro it adds
separate sheet for each data column and I am thinking may be thats why
the error comes up as there is no Sheet 2.

My other question is that in this coding I dont see coding for adding
addtional worksheet, am I correct ?


Naeem
 
D

Dan R.

Here's a shorter way that works...

Sub Test()
For Each cell In ActiveSheet.Range("A1:C1")
If cell.Value = "YES" Then
Set sh = ThisWorkbook.Worksheets.Add
sh.Name = Range("Sheet_Name_" & cell.Column)
Range("Data_" & cell.Column).Copy _
Sheets(Range("Sheet_Name_" & _
cell.Column).Text).Range("A1")
Sheets(Range("Sheet_Name_" & _
cell.Column).Text).Columns("A").AutoFit
End If
Next cell
End Sub
 
N

Nm

Here's a shorter way that works...

Sub Test()
For Each cell In ActiveSheet.Range("A1:C1")
If cell.Value = "YES" Then
Set sh = ThisWorkbook.Worksheets.Add
sh.Name = Range("Sheet_Name_" & cell.Column)
Range("Data_" & cell.Column).Copy _
Sheets(Range("Sheet_Name_" & _
cell.Column).Text).Range("A1")
Sheets(Range("Sheet_Name_" & _
cell.Column).Text).Columns("A").AutoFit
End If
Next cell
End Sub
Click to expand...

Great - That works.

Thank you. I will go through it as well and try to understand.

Thanks again for all your help

Naeem
 
D

Dan Thompson

Dan R. said:
Here's a shorter way that works...

Sub Test()
For Each cell In ActiveSheet.Range("A1:C1")
If cell.Value = "YES" Then
Set sh = ThisWorkbook.Worksheets.Add
sh.Name = Range("Sheet_Name_" & cell.Column)
Range("Data_" & cell.Column).Copy _
Sheets(Range("Sheet_Name_" & _
cell.Column).Text).Range("A1")
Sheets(Range("Sheet_Name_" & _
cell.Column).Text).Columns("A").AutoFit
End If
Next cell
End Sub
Click to expand...


Gee Thats funny that it works for NM cause when I run Dan R. Code I get a
Run-Time Error "Method 'Range' of 'object '_Global' failed"
Whats with ("Sheet_Name_ ect... ") and ("Data_" ...ect) are they user
variables or are they actual vba commands ?
 
N

Nm

Gee Thats funny that it works for NM cause when I run Dan R. Code I get a
Run-Time Error "Method 'Range' of 'object '_Global' failed"
Whats with ("Sheet_Name_ ect... ") and ("Data_" ...ect) are they user
variables or are they actual vba commands ?- Hide quoted text -

- Show quoted text -
Click to expand...


Hi Dan,

The ("Sheet_Name_ ect... ") and ("Data_" ...ect) are ranges in my
file.

Naeem
 
N

Naeem

Hi Dan,

The ("Sheet_Name_ ect... ") and ("Data_" ...ect) are ranges in my
file.

Naeem- Hide quoted text -

- Show quoted text -
Click to expand...

Hi Dan,

The ("Sheet_Name_ ect... ") and ("Data_" ...ect) are ranges in my
file.


Naeem
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

For Each WS .... 2
Help me5 1
Different Results from the Same Macro 3
Macro Loop 0
VBA for Dependents shortcut menu 0
CopyPasteCode 5
Help merging two VBA codes 2
How can i not copy the headers? 3

Top