Macro creates new worksheet (already ready) but i need a little bit of data to be added

[Raju Radhakrishnan]

Hi,

I am attaching a macro file which works fine for me. Which creates new worksheets. But I want this macro not only to create new worksheets but also add automaticaly data from sheet 1 for columns - Vessel Code, Vessel Name, Voyage, Port and Operator.

Please do the needful as am struggling with this for very long time. Thanks

[arlu1201]

By looking at your sheet i am understanding that you want the data split based on the entries in the "Vessel" column.

However, you have the sheetnames ending with 1, 2, etc. like CMA CGM QINGDAO1, CMA CGM QINGDAO2. Which data should go in which sheet?

Also, what about sheets for ALIANCA SANTOS, ALIANCA MANAUS, etc?

[Raju Radhakrishnan]

The macro is designed to prepare the worksheets for all the vessels except the colored ones. These vessels have no data. But what i need is when the macro automatically prepares worksheets, I want the data besides it also to be filled automatically....Please help me out with this

[arlu1201]

You have 2 sheets with the same name and just the ending number different - CMA CGM QINGDAO1 vs CMA CGM QINGDAO2. How does the macro decide where the data should go? In sheet ending with 1 or 2?

[Raju Radhakrishnan]

If the vessel name is same......The data which will be added automatically will be the datas besides the vessel name. i.e. Vessel Code, Vessel name, Voyage, Port, Operator...Thats it....These datas will be added by us manually in the sheet 1 workpage

[arlu1201]

No, you are not understanding my question - why do you have 2 sheets with the same name and just a number difference at the end? How will i know where the record should go to? To CMA CGM QINGDAO1 or CMA CGM QINGDAO2?

[Raju Radhakrishnan]

Leave it....The data inside would not be a similar one...okay?? vessel names can be same but any of the datas can be different...For example Vessel names can me the same like above but the voyage number can be 1207 and 1209 extc...Sorry for the miscommunication buddy

[arlu1201]

Ok, but how should the macro decide which sheet the data should go to? Is there some predetermined rule?

[Raju Radhakrishnan]

Thats the rule which am unaware of. All i know is what i want....if its preparing the worksheets automatically. it should also take the datas besides the vessel name

[arlu1201]

Ok, will there be any problems for you, if you merge both the sheets CMA CGM QINGDAO1 and CMA CGM QINGDAO2 into 1?

[Raju Radhakrishnan]

The excel file I have attached is just a proforma. Actually what happens is we do have CMA 1 and CMA 2....But informations like voyage number, port will be different. So Will it be possible to update it that way??? Its ok if CMA 1 has CMA 2 details and vice versa

[arlu1201]

I am not able to edit your code to add the rows, but maybe i can create one for you from scratch.

You want the sheet names to be created for those rows which are not colored in sheet1, right? Do i have to create the sheets with the numbers at the end?

[Raju Radhakrishnan]

Thanks a lot for your effort brother....Yes sheets should not be created for the colored rows. And the names can be anything. But the first row i.e week should be hyper linked to that sheet

[arlu1201]

Try this code. Put it in a standard module

Option Explicit

Sub copy_rows()
Dim ws As Worksheet
Dim lrow As Long, i As Long
Dim sname As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "Sheet1" Then ws.Delete
Next ws

With Worksheets("Sheet1")
    lrow = .Range("C" & .Rows.Count).End(xlUp).Row
    If lrow = 1 Then Exit Sub
    
    For i = 2 To lrow
        If .Range("C" & i).Interior.ColorIndex <> 43 Then
            sname = .Range("D" & i).Value
            If Not Evaluate("ISREF('" & sname & "'!A1)") Then
                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sname
                .Range("C1:G1").Copy Worksheets(sname).Range("A1")
                Worksheets(sname).Range("F1").Value = "Tp-Doc Number"
                Worksheets(sname).Range("G1").Value = "Error Type 8"
                Worksheets(sname).Range("H1").Value = "BA"
            End If
            .Range("C" & i & ":G" & i).Copy Worksheets(sname).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            With Worksheets(sname).Range("A1:H1")
                .Borders.LineStyle = xlContinuous
                .Interior.ColorIndex = 23
                .Columns.AutoFit
                .Font.Bold = True
            End With
            
            .Range("A" & i).Hyperlinks.Add .Range("A" & i), "", "'" & sname & "'!A1", ""
        End If
    Next i
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

[Raju Radhakrishnan]

Dear that coloring is not proper! Can you please remove it as soon as possible thanks Rest all working fine really!

[arlu1201]

What coloring?

I just used what you had in your code.

[Raju Radhakrishnan]

I just prepared the macro with the code you gave. Its not working fine dear...i will attach the sample macro file...In this worksheets are not prepared for all the white colored vessels...For ex: Santa Philipa....Also its showing some debug...Can i please fix this..Thanks

[Raju Radhakrishnan]

Also this worksheet will be having a huge amount of data....So keep the row limit till atleast 500...thanks

[arlu1201]

Which coloring do you want to remove?

What debug error did you get and which code line was highlighted in yellow?

The code will take care of how many ever rows you want.

[Raju Radhakrishnan]

About coloring....I duno how...when i was adding datas in that macro...after 9 - 10 rows..the cells were getting auto colored. and also error was Run time error : 13, Type mismatch.......yellow colored line was If Not Evaluate("ISREF('" & sname & "'!A1)") Then

[arlu1201]

I ran the macro and i didnt get any issues. No colors, no errors. Can you try again?

[Raju Radhakrishnan]

Its giving the problem when you will remove all the datas in it...and add in another datas in every column....I need these same macro to be used for whole year...and for next year too...so i wil have to prepare this macro month wise...Try removing all the data and add one by one...it gives the error like i mentioned

[arlu1201]

Should i remove the data from the main sheet or the newly created sheets?

[Raju Radhakrishnan]

Remove the data from sheet one....When i will have the macro ready, i need the sheet one to be empty..As and when i will add the data it should work accordingly. Thanks

[arlu1201]

I tried the macro and yet no error. When you run the macro, and get the error. You will see the yellow line in the code. Just hover your mouse over "sname" and let me know what value you see there.

[Raju Radhakrishnan]

Yes this is working fine...I just need one more tweak...macro doesnt need to create worksheet if the error column has 0..Can you please add this condition pelase!!

[arlu1201]

Do you mean besides checking if the row is colored, the macro should also check if the values in column L is not equal to 0? And then create sheet?

[Raju Radhakrishnan]

Absolutely!!! The error column if its 0 then no need to create thanks a lot

[arlu1201]

Try this

Option Explicit

Sub copy_rows()
Dim ws As Worksheet
Dim lrow As Long, i As Long
Dim sname As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "Sheet1" Then ws.Delete
Next ws

With Worksheets("Sheet1")
    lrow = .Range("C" & .Rows.Count).End(xlUp).Row
    If lrow = 1 Then Exit Sub
    
    For i = 2 To lrow
        If .Range("C" & i).Interior.ColorIndex <> 43 or .range("L" & i).value <> 0 Then
            sname = .Range("D" & i).Value
            If Not Evaluate("ISREF('" & sname & "'!A1)") Then
                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sname
                .Range("C1:G1").Copy Worksheets(sname).Range("A1")
                Worksheets(sname).Range("F1").Value = "Tp-Doc Number"
                Worksheets(sname).Range("G1").Value = "Error Type 8"
                Worksheets(sname).Range("H1").Value = "BA"
            End If
            .Range("C" & i & ":G" & i).Copy Worksheets(sname).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            With Worksheets(sname).Range("A1:H1")
                .Borders.LineStyle = xlContinuous
                .Interior.ColorIndex = 23
                .Columns.AutoFit
                .Font.Bold = True
            End With
            
            .Range("A" & i).Hyperlinks.Add .Range("A" & i), "", "'" & sname & "'!A1", ""
        End If
    Next i
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

[Raju Radhakrishnan]

Dear, all is working well but When i added 0 in column L, its still creating the worksheet

[arlu1201]

Try this

Option Explicit

Sub copy_rows()
Dim ws As Worksheet
Dim lrow As Long, i As Long
Dim sname As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "Sheet1" Then ws.Delete
Next ws

With Worksheets("Sheet1")
    lrow = .Range("C" & .Rows.Count).End(xlUp).Row
    If lrow = 1 Then Exit Sub
    
    For i = 2 To lrow
        If .Range("L" & i).Value <> 0 Then
            If .Range("C" & i).Interior.ColorIndex <> 43 Then
                sname = .Range("D" & i).Value
                If Not Evaluate("ISREF('" & sname & "'!A1)") Then
                    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sname
                    .Range("C1:G1").Copy Worksheets(sname).Range("A1")
                    Worksheets(sname).Range("F1").Value = "Tp-Doc Number"
                    Worksheets(sname).Range("G1").Value = "Error Type 8"
                    Worksheets(sname).Range("H1").Value = "BA"
                End If
                .Range("C" & i & ":G" & i).Copy Worksheets(sname).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                With Worksheets(sname).Range("A1:H1")
                    .Borders.LineStyle = xlContinuous
                    .Interior.ColorIndex = 23
                    .Columns.AutoFit
                    .Font.Bold = True
                End With
            
                .Range("A" & i).Hyperlinks.Add .Range("A" & i), "", "'" & sname & "'!A1", ""
            End If
        End If
    Next i
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub