Modifying Macro

[simplymidori]

Looking to see if this can be modified to paste FORMAT as well. Thanks


Sub CopyPaste()

Dim LMainSheet As String
Dim LRow As Integer
Dim LContinue As Boolean

Dim LColAMaster As String
Dim LColATest As String

'Retrieve name of sheet that contains the data
LMainSheet = ActiveSheet.Name

'Initialize variables
LContinue = True
LRow = 2

'Start comparing with cell A2
LColAMaster = "A2"

'Loop through all column A values until a blank cell is found
While LContinue = True

LRow = LRow + 1
LColATest = "A" & CStr(LRow)

'Found a blank cell, do not continue
If Len(Range(LColATest).Value) = 0 Then
LContinue = False
End If

'Found occurrence that did not match, copy data to new sheet
If Range(LColAMaster).Value <> Range(LColATest).Value Then

'Copy headings
Range("A1:AU1").Select
Selection.Copy

'Add new sheet and paste headings into new sheet
Sheets.Add.Name = Range(LColAMaster).Value
ActiveSheet.Paste
Columns("A:AU").ColumnWidth = 15
Range("A1").Select

'Copy data from columns A - Z
Sheets(LMainSheet).Select
Range(LColAMaster & ":AD" & CStr(LRow - 1)).Select
Selection.Copy

'Paste results
Sheets(Range(LColAMaster).Value).Select
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select

'Go back to Main sheet and continue where left off
Sheets(LMainSheet).Select
LColAMaster = "A" & CStr(LRow)

End If

Wend

Range("A1").Select
Application.CutCopyMode = False

MsgBox "Copy has completed."

End Sub

 

[Per Jessen]

Looking to see if this can be modified to paste FORMAT as well.  Thanks

Sub CopyPaste()

Dim LMainSheet As String
Dim LRow As Integer
Dim LContinue As Boolean

Dim LColAMaster As String
Dim LColATest As String

'Retrieve name of sheet that contains the data
LMainSheet = ActiveSheet.Name

'Initialize variables
LContinue = True
LRow = 2

'Start comparing with cell A2
LColAMaster = "A2"

'Loop through all column A values until a blank cell is found
While LContinue = True

LRow = LRow + 1
LColATest = "A" & CStr(LRow)

'Found a blank cell, do not continue
If Len(Range(LColATest).Value) = 0 Then
LContinue = False
End If

'Found occurrence that did not match, copy data to new sheet
If Range(LColAMaster).Value <> Range(LColATest).Value Then

'Copy headings
Range("A1:AU1").Select
Selection.Copy

'Add new sheet and paste headings into new sheet
Sheets.Add.Name = Range(LColAMaster).Value
ActiveSheet.Paste
Columns("A:AU").ColumnWidth = 15
Range("A1").Select

'Copy data from columns A - Z
Sheets(LMainSheet).Select
Range(LColAMaster & ":AD" & CStr(LRow - 1)).Select
Selection.Copy

'Paste results
Sheets(Range(LColAMaster).Value).Select
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select

'Go back to Main sheet and continue where left off
Sheets(LMainSheet).Select
LColAMaster = "A" & CStr(LRow)

End If

Wend

Range("A1").Select
Application.CutCopyMode = False

MsgBox "Copy has completed."

End Sub

Hi

Substitute
.paste
with
.PasteSpecial Paste:=xlAll

Regards,
Per

 

[simplymidori]

I substituted and had a problem with this line

Sheets.Add.Name = Range(LColAMaster).Value
ActiveSheet.PasteSpecial Paste:=xlAll
Columns("A:AU").ColumnWidth = 15
Range("A1").Select

 

[simplymidori]

I took Paste:=xlAll off and it worked but my columns are not in the right
width.
Thanks for the help