VBA help needed. Copy rows.

[craig2525]

I have VBA code from another work book. The original was creating new sheets, headers and copying rows based on column A. I am making a new workbook that will do the same except I want to copy the rows based on column G instead. I made it as far as creating the sheets and headers but the rows do not copy. Here is the copy part of the code.

 

[davesexcel]

Can you change column A to Column G and where is the original code, could you supply the actual code, not a picture.

 

[craig2525]

Option Explicit

Sub CreateSheets()

    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet

        Set RngBeg = Worksheets("Sheet1").Range("G2")
        Set RngEnd = Worksheets("Sheet1").Cells(Rows.Count, "G").End(xlUp)

        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub
Application.ScreenUpdating = False
        For Each Cell In Worksheets("Sheet1").Range(RngBeg, RngEnd)
            On Error Resume Next
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Format(Cell.Value, "[$-409]dmmmyy;@"))

                ' Add a new worksheet and name it.
                If Err <> 0 Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                    Wks.Name = Format(Cell.Value, "[$-409]dmmmyy;@")
                End If
            On Error GoTo 0
        Next Cell
Application.ScreenUpdating = True
MakeHeaders
End Sub

Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "Sheet1"
Application.ScreenUpdating = False
For dst = 1 To Sheets.Count
    If Sheets(dst).Name <> srcSheet Then
    Sheets(srcSheet).Rows("1:1").Copy
    Sheets(dst).Activate
    Sheets(dst).Range("A1").PasteSpecial xlPasteValues
    'ActiveSheet.PasteSpecial xlPasteValues
    Sheets(dst).Range("A1").Select
    End If
Next
Application.ScreenUpdating = True
CopyData
End Sub

Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
On Error Resume Next
Lastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Dim ans As String
Dim ans2 As String

NoVisi

    For i = 2 To Lastrow
    ans = Sheets("Sheet1").Cells(i, 1).Value
    ans2 = Format(ans, "[$-409]dmmmyy;@")
        Sheets("Sheet1").Rows(i).Copy Sheets(ans2).Rows(Sheets(ans2).Cells(Rows.Count, "A").End(xlUp).Row + 1)
    Next
    
Visi

Application.ScreenUpdating = True

Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A2").Select

Exit Sub

Application.ScreenUpdating = True

End Sub

Sub NoVisi()
Dim CommandButton1 As Object

CommandButton1.Visible = False

End Sub

Sub Visi()
Dim CommandButton1 As Object

CommandButton1.Visible = True
End Sub

Private Sub CommandButton1_Click()

End Sub

 

[craig2525]

I have and it works but the file I get to create these sheets is sent to me in that order. I just wanted to copy and paste and have it automatically create the other pages.

 

[craig2525]

 

[davesexcel]

Try this,
There is no error checking, or formatting.

Sub MakeSheets()
    Dim cUnique As Collection
    Dim rng  As Range, fRng As Range
    Dim c  As Range
    Dim sh As Worksheet, ws As Worksheet
    Dim vNum As Variant
    
    Set sh = ThisWorkbook.Sheets("Sheet1")
    
    With sh
        Set rng = .Range("G2:G" & .Cells(.Rows.Count, "G").End(xlUp).Row)
        Set fRng = .Range("A1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
        Set cUnique = New Collection
        
        On Error Resume Next
        
        For Each c In rng.Cells
            cUnique.Add c.Value, CStr(c.Value)
        Next c
        
        On Error GoTo 0
        Application.ScreenUpdating = False
        For Each vNum In cUnique
            .Range("A1").AutoFilter field:=7, Criteria1:=vNum
            Set fRng = .Range("A1:H" & .Cells(.Rows.Count, "G").End(xlUp).Row)
            Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
            ws.Name = vNum
            fRng.Copy ws.Range("A1")
            
        Next vNum
        
        .AutoFilterMode = False
        Application.Goto Reference:=.Range("A1"), scroll:=True
    End With
    MsgBox "Done"
End Sub

 

[craig2525]

Works perfect. Thank you.