Hi all,
I am almost there. I am trying to copy data from Sheet1 to other sheets created. I get the sheets generated, headers copied but the data is not copying. I am not that versed in VBA. This is code I am trying manipulate from another workbook I have.
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("A1").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
I am almost there. I am trying to copy data from Sheet1 to other sheets created. I get the sheets generated, headers copied but the data is not copying. I am not that versed in VBA. This is code I am trying manipulate from another workbook I have.
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("A1").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