socalconsult
12-28-2010, 02:13 PM
All,
I am trying to copy and paste from one sheet into multiple different worksheets based on the value of cells in a column.
My idea was to copy the contents first, which works, followed by copying the column width and formatting later. My for loop at the bottom is not working, and I am not sure why. I think there is probably a faster way of copying the contents and widths and formatting at the same time, but my thoughts were to split the activities up so it would be easier to troubleshoot.
Any ideas would be appreciated
Sub SplitSheet()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Dim wsheet As Worksheet
Dim wb As Workbook
Application.ScreenUpdating = False
With ActiveSheet
Application.DisplayAlerts = False
Application.DisplayAlerts = True
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=Range("M2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iStart = 2
For i = 2 To lastrow
If .Range("M" & i).Value <> .Range("M" & i + 1).Value Then
iEnd = i
Sheets.Add after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Range("M" & iStart).Value
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
iStart = iEnd + 1
End If
Next i
End With
'This next section fails where I attempt to copy the column properties from the first worksheet and paste them into all of the other sheets
Sheets("Sheet1").Range("A:Z").Copy
For Each wsheet In wb.Worksheets
With wsheet
wsheet.Range(Cells(1, 1), Cells(1, LastCol)).PasteSpecial xlPasteFormats
End With
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
I am trying to copy and paste from one sheet into multiple different worksheets based on the value of cells in a column.
My idea was to copy the contents first, which works, followed by copying the column width and formatting later. My for loop at the bottom is not working, and I am not sure why. I think there is probably a faster way of copying the contents and widths and formatting at the same time, but my thoughts were to split the activities up so it would be easier to troubleshoot.
Any ideas would be appreciated
Sub SplitSheet()
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Dim wsheet As Worksheet
Dim wb As Workbook
Application.ScreenUpdating = False
With ActiveSheet
Application.DisplayAlerts = False
Application.DisplayAlerts = True
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=Range("M2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iStart = 2
For i = 2 To lastrow
If .Range("M" & i).Value <> .Range("M" & i + 1).Value Then
iEnd = i
Sheets.Add after:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Range("M" & iStart).Value
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
iStart = iEnd + 1
End If
Next i
End With
'This next section fails where I attempt to copy the column properties from the first worksheet and paste them into all of the other sheets
Sheets("Sheet1").Range("A:Z").Copy
For Each wsheet In wb.Worksheets
With wsheet
wsheet.Range(Cells(1, 1), Cells(1, LastCol)).PasteSpecial xlPasteFormats
End With
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub