Dave,
Firstly, many thanks for your time, patient and perseverance. I created a
macro name called EOM (as opposed to ALT+11 ) and it worked.
However, I have the following observation: -
The header row from each sheet (row 2) is copied into the new sheet, which I
dont want. (Can this be fixed?), if not I can delete them manually (rows 1 &
2 on all sheets are headers, data only commences in row 3 onwards. Basically
it puts 4 headers into the new sheet, I only want 1.
Secondly, I have created a macro to undertake some formatting and copied the
code into the macro code you provided and it works.
The code looks like:-
ActiveWindow.Zoom = 67
Columns("B:B").Select
Selection.NumberFormat = "dd/mm/yy"
Columns("D:D").Select
Selection.NumberFormat = "dd/mm/yy"
Columns("I:I").Select
Selection.NumberFormat = "dd/mm/yy"
Columns("J:J").Select
Selection.NumberFormat = "hh:mm AM/PM"
Columns("A:A").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("H:H").EntireColumn.AutoFit
Columns("K:K").EntireColumn.AutoFit
Columns("G:G").Select
Selection.Replace What:=" /", Replacement:="/", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Key2:=Range("G2") _
, Order2:=xlAscending, Key3:=Range("F2"), Order3:=xlAscending,
Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Is there a way to make this code more efficient, as I have been lead to
believe that you dont necessarily have to do the selects?
Lastly, the contents of the new sheet are as follows in column A:-
Company A
Company A
Company B
Company B
Company B
Company C
Company C
Company C
Company E
Company E
Etc.
Is there any way that I can automatically get a sheet set up for each
Company A, B, C, €¦with all data in to their corresponding sheets? Including a
header?
i.e. From the example above:-
Sheet called Company A with data for 2 rows into the sheet plus header at
the top
Sheet called Company B with data for 3 rows into the sheet plus header at
the top
Sheet called Company C with data for 3 rows into the sheet plus header at
the top
Sheet called Company E with data for 2 rows into the sheet plus header at
the top
Once again a ver big thank you.
"Dave Peterson" wrote:
Any idea which line caused the error?
I didn't get any error when I ran it.
But I like this version better--destcell is pointing to the correct sheet. You
dropped some code from the original and I didn't notice it in your newer
versions.
Option Explicit
Sub EOM()
Dim Wks As Worksheet
Dim DestCell As Range
Dim newWks As Worksheet
Dim HeadersAreDone As Boolean
Dim mySelectedSheets As Object
Dim myRngToCopy As Range
Set mySelectedSheets = ActiveWindow.SelectedSheets
ActiveWorkbook.Worksheets(1).Select
If mySelectedSheets.Count < 3 Then
MsgBox "Please Group exactly 3 sheets before you run this macro!"
Exit Sub
End If
Set newWks = Workbooks.Add(1).Worksheets(1)
HeadersAreDone = False
ActiveWorkbook.Unprotect
For Each Wks In mySelectedSheets
With Wks
If HeadersAreDone = True Then
'do nothing
Else
.Rows(2).Copy _
Destination:=newWks.Range("a1")
HeadersAreDone = True
Set DestCell = newWks.Range("a2")
End If
.Unprotect Password:=""
.Range("a2", .Cells.SpecialCells(xlCellTypeLastCell)).Copy
DestCell.PasteSpecial Paste:=xlPasteValues
.Protect Password:=""
With newWks
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
End With
Next Wks
End Sub
Pank Mehta wrote:
Dave,
Having copied the latest code I get a "400" error.
"Dave Peterson" wrote:
That snippet could have been editted when you merged it with the existing code:
Option Explicit
Sub EOM()
Dim Wks As Worksheet
Dim DestCell As Range
Dim newWks As Worksheet
Dim HeadersAreDone As Boolean
Dim mySelectedSheets As Object
Dim myRngToCopy As Range
Set mySelectedSheets = ActiveWindow.SelectedSheets
If mySelectedSheets.Count < 3 Then
MsgBox "Please Group exactly 3 sheets before you run this macro!"
Exit Sub
End If
Set newWks = Workbooks.Add(1).Worksheets(1)
HeadersAreDone = False
ActiveWorkbook.Unprotect
For Each Wks In mySelectedSheets
With Wks
If HeadersAreDone = True Then
'do nothing
Else
.Rows(2).Copy _
Destination:=newWks.Range("a1")
HeadersAreDone = True
Set DestCell = newWks.Range("a2")
End If
.Unprotect password:=""
.Range("a2", .Cells.SpecialCells(xlCellTypeLastCell)).Copy
DestCell.PasteSpecial Paste:=xlPasteValues
.Protect password:=""
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
Next Wks
End Sub
I deleted the "With Worksheets("someworksheet")" and associated "end with"
statements.
Pank Mehta wrote:
Dave,
Sorry to be a pain in A**E.
The code I have is:-
Option Explicit
Sub EOM()
Dim Wks As Worksheet
Dim DestCell As Range
Dim newWks As Worksheet
Dim HeadersAreDone As Boolean
Dim mySelectedSheets As Object
Dim myRngToCopy As Range
Set mySelectedSheets = ActiveWindow.SelectedSheets
If mySelectedSheets.Count < 3 Then
MsgBox "Please Group exactly 3 sheets before you run this macro!"
Exit Sub
End If
Set newWks = Workbooks.Add(1).Worksheets(1)
HeadersAreDone = False
ActiveWorkbook.Unprotect
For Each Wks In mySelectedSheets
With Wks
If HeadersAreDone = True Then
'do nothing
Else
.Rows(2).Copy _
Destination:=newWks.Range("a1")
HeadersAreDone = True
Set DestCell = newWks.Range("a2")
End If
With Worksheets("someworksheet")
.Unprotect password:=""
.Range("a2", .Cells.SpecialCells(xlCellTypeLastCell)).Copy
DestCell.PasteSpecial Paste:=xlPasteValues
.Protect password:=""
End With
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
Next Wks
End Sub
Unfortunately, I get the message "subscript out of range". Please help.
Woulf it help if we communicate directly via emails?. Once we (well you) have
cracked it I would still post the full result to the newsgroup just in case
it is usefull to other people?
"Dave Peterson" wrote:
First, by directing this to me, you do limit the number of response from
others. And that will hurt you in the long run--lots of people could have
helped.
Second, you have to unprotect the worksheet.
activesheet.unprotect password:="yourpasswordhere"
(I don't recall if this was for the activesheet or some other sheet, though.)
But from the snippet of code you posted, it should fit in right before this
line:
.unprotect password:="yourpasswordhere"
.Range("a2", .Cells.SpecialCells(xlCellTypeLastCell)).Copy _
Destination:=DestCell
.protect password:="yourpasswordhere"
And if you only want the values, you can either copy|paste special values or
just assign the value.
dim myRngToCopy as range
'...some more code
with worksheets("someworksheet")
.unprotect password:="yourpasswordhere"
set myrngtocopy = .Range("a2", .Cells.SpecialCells(xlCellTypeLastCell))
destcell.resize(myrngtocopy.rows.count,myrngtocopy .columns.count).value _
= myrngtocopy.value
.protect password:="yourpasswordhere"
end with
======
or equivalently:
with worksheets("someworksheet")
.unprotect password:="yourpasswordhere"
.Range("a2", .Cells.SpecialCells(xlCellTypeLastCell)).copy
destcell.pastespecial paste:=xlpastevalues
.protect password:="yourpasswordhere"
end with
I like the assignment of values myself.
Ann wrote:
Dave,
I have finally, got round to testing the code that you were kind enough to
provide.
Having run the code I get the message "Run Time error 1004, You cannot use
this command on a protected sheet. To unprotect ....". When I click on the
debug statement it points to the line with the following code:-
.Range("a2", .Cells.SpecialCells(xlCellTypeLastCell)).Copy _
Destination:=DestCell
I inserted "ActiveWorkbook.Unprotect" prior to the above statement and also
prior to the first IF statement, but unfortunately this does not resolve the
problem.
It has managed to copy the first sheet, inserted the data onto a new sheet
and then produces the above message.
Lastly, on the copy how do I change it so that it does a special and copies
values as opposed to formulas.
Help much appreciated.
"Pank Mehta" wrote:
Copying multiple sheets from one book 2 another and undertake special editing.
Apologies as the following is long winded.
I have a workbook that has 12 sheets (i.e. 1 for each month of the Year).
Each sheet contains the following: -
Header row;
Customer name; date contacted and work location (and other information).
One can have multiple rows for each customer as they can contact us many
times a day for work to be undertaken at different locations.
On a monthly basis we have to undertake a charging process for customers who
have used our services for the last month.
At the moment we all copy the information from each monthly sheet to another
workbook and sort it on Customer name.
Having sorted the information, someone manually creates a worksheet for each
customer using Cut + Paste and then creates an invoice.
Things have now changed and we have to charge on a quarterly basis.
Is there any way that a front-end screen can be written in which one
specifies sheet names that need to be charged for and a destination sheet
name. Once the sheet names have been entered, we would like the appropriate
sheets (may be selected columns) to be copied to an existing workbook (using
Paste special and Values) with the name specified as destination. Obviously
once the sheets have been copied, there will be three headers, I would
ideally like to search the destination sheet and delete the extra 2 headers
automatically before it is sorted in the format that is required.
Having sorted the sheet, we would like to create individual sheets for all
the different customers that exist on the master sheet and have all rows for
that customer copied into their named sheet.
Any help offered would be most appreciated.
--
Dave Peterson
--
Dave Peterson
--
Dave Peterson
|