Report Question?

  • Thread starter Thread starter Michael168
  • Start date Start date
M

Michael168

Can someone help for this kind of report?
I have a worksheet range from A1:J3788.
Column 1 contains the date informations.
Column 2 to 9 contains customers name.
How to write each individual customer to a new sheet which contain only
2 columns

i.e. date and name.

e.g. In master record (Sheet1) contains

29/10/2003 Albert Robert Bobby....etc
30/10/2003 Robert Bobby Albert ....etc.

The sheet name will be auto named after the name of the customer.

So in sheet Albert will be
29/10/2003 Albert
30/10/2003 Albert

In sheet Robert will be
29/10/2003 Robert
30/10/2003 Robert

In sheet Bobby will be
29/10/2003 Bobby
30/10/2003 Bobby

The routine will start from the first row of sheet1 until the last
row.

Thanks you.
 
Michael,

Try the code below, with the sheet active. This assumes there are
headers in row 1.

HTH,
Bernie
MS Excel MVP

Sub TryNow()
Dim myCell As Range
Dim myRange As Range
Dim mySht As Worksheet
Dim mySrc As Worksheet
Dim myVal As String

Application.ScreenUpdating = False
ActiveSheet.Copy Sheets(1)
Set mySrc = ActiveSheet
Set myRange = mySrc.Range("B2:J3788")
While Application.CountBlank(myRange) <> myRange.Cells.Count
Set myRange = myRange.SpecialCells(xlCellTypeConstants, 2)
myVal = myRange(1).Value
Set mySht = Worksheets.Add
mySrc.Activate
mySht.Name = myVal
mySht.Range("A:A").NumberFormat = "mm/dd/yyyy"
For Each myCell In myRange
If myCell.Value = myVal Then
With mySht.Range("A65536").End(xlUp)(2)
.Value = Cells(myCell.Row, 1).Value
.Offset(0, 1).Value = myCell.Value
End With
myCell.ClearContents
End If
Next myCell
mySht.Range("A:B").EntireColumn.AutoFit
Set myRange = mySrc.Range("B2:J3788")
Wend
Application.DisplayAlerts = False
mySrc.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
 
Hi! Bernie Deitrick,

Thanks for your fast help. A little problem exists. That is when I run
the macro the second time, it gives me "run-time error 1004" stating
that "cannot rename a sheet to the same name as another sheet".
How to overcome this problem? I think all the newly created sheet need
to be deleted before running. I need to run the macro at least on daily
basic because the master record keep on updating daily.
Your modification help needed and appreciated.

Thank you.
 
Michael,

The code below will work on subsequent trials. It will color any data
that was tranfered as green - my way, though not the only way - to
keep from double transferring data when you run it a second time. You
can change the colorindex = 4 lines (two places) to another color
that better pleases you. Note that you need to copy the function below
as well into your code module.

HTH,
Bernie
MS Excel MVP


Sub TryNow2()
Dim myCell As Range
Dim myRange As Range
Dim mySht As Worksheet
Dim mySrc As Worksheet
Dim myOrig As Worksheet
Dim myVal As String

Application.ScreenUpdating = False
Set myOrig = ActiveSheet
ActiveSheet.Copy Sheets(1)
Set mySrc = ActiveSheet
Set myRange = mySrc.Range("B2",
Range("B2").CurrentRegion.SpecialCells(xlCellTypeLastCell))
While Application.CountBlank(myRange) <> myRange.Cells.Count
Set myRange = myRange.SpecialCells(xlCellTypeConstants, 2)
myVal = myRange(1).Value
If Not WorksheetExists(myVal) Then
Set mySht = Worksheets.Add
mySht.Name = myVal
Else
Set mySht = Worksheets(myVal)
End If
mySrc.Activate
mySht.Range("A:A").NumberFormat = "mm/dd/yyyy"
For Each myCell In myRange
If myCell.Value = myVal Then
If myCell.Interior.ColorIndex <> 4 Then
With mySht.Range("A65536").End(xlUp)(2)
.Value = Cells(myCell.Row, 1).Value
.Offset(0, 1).Value = myCell.Value
myOrig.Range(myCell.Address).Interior.ColorIndex = 4
End With
End If
myCell.ClearContents
End If
Next myCell
mySht.Range("A:B").EntireColumn.AutoFit
Set myRange = mySrc.Range("B2:J3788")
Wend
Application.DisplayAlerts = False
mySrc.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Function WorksheetExists(wksName As String) As Boolean
Dim dummy_wks As Worksheet
On Error Resume Next
Set dummy_wks = Worksheets(wksName)
If Err = 0 Then
WorksheetExists = True
Else
WorksheetExists = False
End If
Set dummy_wks = Nothing
End Function
 
Aargh, forgot to change one line to account for the larger range
(possibly larger range) for subsequent runs. I also fixed a text
wrapping problem.

HTH,
Bernie
MS Excel MVP

Sub TryNow2()
Dim myCell As Range
Dim myRange As Range
Dim mySht As Worksheet
Dim mySrc As Worksheet
Dim myOrig As Worksheet
Dim myVal As String

Application.ScreenUpdating = False
Set myOrig = ActiveSheet
ActiveSheet.Copy Sheets(1)
Set mySrc = ActiveSheet
Set myRange = mySrc.Range("B2", _
Range("B2").CurrentRegion.SpecialCells(xlCellTypeLastCell))
While Application.CountBlank(myRange) <> myRange.Cells.Count
Set myRange = myRange.SpecialCells(xlCellTypeConstants, 2)
myVal = myRange(1).Value
If Not WorksheetExists(myVal) Then
Set mySht = Worksheets.Add
mySht.Name = myVal
Else
Set mySht = Worksheets(myVal)
End If
mySrc.Activate
mySht.Range("A:A").NumberFormat = "mm/dd/yyyy"
For Each myCell In myRange
If myCell.Value = myVal Then
If myCell.Interior.ColorIndex <> 4 Then
With mySht.Range("A65536").End(xlUp)(2)
.Value = Cells(myCell.Row, 1).Value
.Offset(0, 1).Value = myCell.Value
myOrig.Range(myCell.Address).Interior.ColorIndex = 4
End With
End If
myCell.ClearContents
End If
Next myCell
mySht.Range("A:B").EntireColumn.AutoFit
Set myRange = mySrc.Range("B2", _
Range("B2").CurrentRegion.SpecialCells(xlCellTypeLastCell))
Wend
Application.DisplayAlerts = False
mySrc.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Function WorksheetExists(wksName As String) As Boolean
Dim dummy_wks As Worksheet
On Error Resume Next
Set dummy_wks = Worksheets(wksName)
If Err = 0 Then
WorksheetExists = True
Else
WorksheetExists = False
End If
Set dummy_wks = Nothing
End Function





Bernie Deitrick said:
Michael,

The code below will work on subsequent trials. It will color any data
that was tranfered as green - my way, though not the only way - to
keep from double transferring data when you run it a second time. You
can change the colorindex = 4 lines (two places) to another color
that better pleases you. Note that you need to copy the function below
as well into your code module.

HTH,
Bernie
MS Excel MVP


Sub TryNow2()
Dim myCell As Range
Dim myRange As Range
Dim mySht As Worksheet
Dim mySrc As Worksheet
Dim myOrig As Worksheet
Dim myVal As String

Application.ScreenUpdating = False
Set myOrig = ActiveSheet
ActiveSheet.Copy Sheets(1)
Set mySrc = ActiveSheet
Set myRange = mySrc.Range("B2",
Range("B2").CurrentRegion.SpecialCells(xlCellTypeLastCell))
While Application.CountBlank(myRange) <> myRange.Cells.Count
Set myRange = myRange.SpecialCells(xlCellTypeConstants, 2)
myVal = myRange(1).Value
If Not WorksheetExists(myVal) Then
Set mySht = Worksheets.Add
mySht.Name = myVal
Else
Set mySht = Worksheets(myVal)
End If
mySrc.Activate
mySht.Range("A:A").NumberFormat = "mm/dd/yyyy"
For Each myCell In myRange
If myCell.Value = myVal Then
If myCell.Interior.ColorIndex <> 4 Then
With mySht.Range("A65536").End(xlUp)(2)
.Value = Cells(myCell.Row, 1).Value
.Offset(0, 1).Value = myCell.Value
myOrig.Range(myCell.Address).Interior.ColorIndex = 4
End With
End If
myCell.ClearContents
End If
Next myCell
mySht.Range("A:B").EntireColumn.AutoFit
Set myRange = mySrc.Range("B2:J3788")
Wend
Application.DisplayAlerts = False
mySrc.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Function WorksheetExists(wksName As String) As Boolean
Dim dummy_wks As Worksheet
On Error Resume Next
Set dummy_wks = Worksheets(wksName)
If Err = 0 Then
WorksheetExists = True
Else
WorksheetExists = False
End If
Set dummy_wks = Nothing
End Function
Click to expand...
 
Hi!Bernie Deitrick,

Thank you for trynow2() macro. Everything runs fine except when the
cell value in the master contain only numeric number it gives the
run-time error '1004' again stating "No cells were found". I try to
figure out but cannot solve it myself.

e.g. Mastersheet Record

date cust1 cust2 cust3 cust4 cust5 .....etc
10/29/2003 albert robert bobby 2010 2011
10/29/2003 2020 kintown kampar robert
10/30/2003 robert bobby albert
10/31/2003 albert bobby robert niceguy

Cust cells with name are cash sales customer and with numeric number
are credit term customers. In this case how to solve this problem. On
each individual report sheet, I would like to add in 1 more cell for
each row-no from the master sheet so that it make me easy to trace
against the mastersheet data.

Hope this will not cause you a lot of trouble.

Thanks & Regards
Michael168
 
Michael,

Wherever this appears:
..SpecialCells(xlCellTypeConstants, 2)

Change it to:
..SpecialCells(xlCellTypeConstants, 3)

This change will make the macro work with numbers and string
constants. It will still not work with formulas, so in your data base
you can't use something like =AnotherCell.

HTH,
Bernie
MS Excel MVP
 
For the second, request (adding the row number of the original data),
after the line

.Offset(0, 1).Value = myCell.Value

add the line

.Offset(0, 2).Value = myCell.Row

HTH,
Bernie
MS Excel MVP
 
Back
Top