excel automate copying cells from row

[mocnak]

hello,
i need to create following macro :
do while (column, row) is not empty
if (row).(column) is not equal (row+1).(column) then
take sheet2, copy and paste it, and paste values from that row to specific cells.
if you find that (row).(column) is equal (row-1).(column) then don't copy and create new sheet but copy those values to sheet with same name.
i tried to find some help here
"stackoverflow.com/questions/2538449/excel-macro-to-create-sheets"
, but still it's not working.
can you help me with it ? or, this code :


Sub Button1_Click()
Dim newsheetname As String
Dim isometry As String
Application.ScreenUpdating = False
Worksheets("Sheet1").Activate
x = 2
Do While Worksheets("Sheet1").Cells(x, 4) <> ""
isometry = Sheet1.Cells(x, 4)
If Cells(x, 4) <> Cells(x - 1, 4) Then
Sheets("template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = isometry 'Sheets(Sheets.Count).Name = isometry
Else
Worksheets(isometry).Activate
If Cells(x, 1) = "07" And Cells(x, 3) = "GDH" Then
Sheets(Sheets.Count).Select
Cells(33, 2) = Sheet1.Cells(x, 4) 'isometry
Cells(33, 28) = Sheet1.Cells(x, 32) 'date
End If
End If
x = x + 1
Worksheets("Sheet1").Activate
Loop
End Sub



and it looks like working, but i get error message when it tries to create new sheet with anme that already exists. can anyone help please ? thanks ...

[SamT]

I hope this is what you want. In your code:
IF Value in "D" changes, make isometry sheet if needed
OR update values in isometry sheet.

In this code:
If Column "D" changes, make isometry sheet if needed
ALWAYS update values.



Sub Button1_Click()
Application.ScreenUpdating = False
x = 2
With Worksheets("Sheet1")
Do While .Cells(x, 4) <> ""
'When value in Column "D" changes
If Cells(x, 4) <> Cells(x - 1, 4) Then
If Sheets(Cells(x, 4)) Is Nothing Then
Sheets("template").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Cells(x, 4) 'Sheets(Sheets.Count).Name = isometry
End If
End If
'For every cell in Column "D"
If Cells(x, 1) = "07" And Cells(x, 3) = "GDH" Then
Sheets(Cells(x, 4)).Cells(33, 2) = Sheet1.Cells(x, 4) 'isometry
Sheets(Cells(x, 4)).Cells(33, 28) = Sheet1.Cells(x, 32) 'date
End If
x = x + 1
Loop
End With
Application.ScreenUpdating = True
End Sub

[mocnak]

i tried it and i get error:13 "type mismatch at line :

If Sheets(Cells(CurRow, ChkCol)) Is Nothing Then
thanks for post btw

[SamT]

That code did'nt make sense to me. See edited post above

I edited it while you were trying it.

[SamT]

If you get same error change
'All

Sheets(Cells(x, 4))
'and
ActiveSheet.Name = Cells(x, 4)


TO

Sheets(Cells(x, 4).Text)
'and
ActiveSheet.Name = Cells(x, 4).Text

[mocnak]

i did changes you mentioned, and now i get error : subscript out of range on line :


"If Sheets(Cells(x, 4).Text) Is Nothing Then"

[SamT]

mocnak, I am very embarrassed. :banghead::banghead::banghead:




On Error Resume Next
If Sheets(Cells(x, 4).Text) Is Nothing Then
On Error GoTo 0