Long VBA Code - Can it be reduced

  • Thread starter Thread starter Nm
  • Start date Start date
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
 
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
 
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
 
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
 
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
 
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
 
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
 
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 ?
 
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
 
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
 
Back
Top