Check more Sheets but keep format

[pantakos]

Can you please help me.

If I want to check another column at the same sheet (and all other sheets in the array) what can I do?

I tried to change sht = Array("E") to sht = Array("E", "K") in order to check both Columns and add it where the code paste the values, but no luck.

I need to keep the table.

What can I do?



Thank you in advance,

Gerasimos



SAMPLE5.xlsm



PS: Question have been posted here https://www.excelforum.com/exc…-problem.html#post5658628 and Check more Sheets but keep format - OzGrid Free Excel/VBA Help Forum

 

[pantakos]

And something else, I need only numeric values to test and not alphabetical
Can this be done?

Thank you again

 

[mumps]

Try:

Sub BuiltIT()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, desWS As Worksheet, rng As Range, lRow As Long
    Set desWS = Sheets("PROFORMA")
    With desWS
        .Range("A15") = "x"
        .ListObjects("Table5").DataBodyRange.Delete
        .Range("E15").Formula = "=C15*D15"
        .Rows(16 & ":" & Sheets("PROFORMA").Rows.Count).Delete
    End With
    For Each ws In Sheets
        If ws.Name <> "PROFORMA" Then
            With ws
                If .Range("E" & .Rows.Count).End(xlUp).Row > 12 Or .Range("K" & .Rows.Count).End(xlUp).Row > 12 Then
                    With desWS.Cells(.Rows.Count, "B").End(xlUp).Offset(1)
                        .Value = ws.Name
                        .Interior.ColorIndex = 6
                    End With
                End If
                If .Range("E" & .Rows.Count).End(xlUp).Row > 12 Then
                    For Each rng In .Range("E13", .Range("E" & .Rows.Count).End(xlUp))
                        If rng <> "" And IsNumeric(rng) Then
                            With desWS
                                .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(, 3).Value = Array(rng.Offset(, -3), rng.Offset(, -1), rng)
                            End With
                        End If
                    Next rng
                End If
                If .Range("K" & .Rows.Count).End(xlUp).Row > 12 Then
                    For Each rng In .Range("K13", .Range("K" & .Rows.Count).End(xlUp))
                        If rng <> "" And IsNumeric(rng) Then
                            With desWS
                                .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(, 3).Value = Array(rng.Offset(, -3), rng.Offset(, -1), rng)
                            End With
                        End If
                    Next rng
                End If
            End With
        End If
    Next ws
    desWS.Rows(15).Delete
    Application.ScreenUpdating = True
End Sub

 

[pantakos]

@mumps Yes! That is perfect! Thank you !

(If need something else for the same code can I bother you again?)

Thanks !

 

[mumps]

You are very welcome. You can post a follow up question in this thread.

 

[pantakos]

@mumps And of course I need your help.

I need to create a new sheet that it is only has 1 row and 2 columns

Description

PCS

And fill starting from A2 with the same data as above but not enter the worksheet name, but only the values. I tried to make it work, but I am no good with offset etc, as I am new with vba coding.
Can you help me again?

Thank you!

 

[mumps]

Do you want a separate macro or do you want the existing macro to perform this task as well?

 

[pantakos]

Separate macro will be better as I would use it to make a button.

Thank you!

 

[mumps]

Assign this macro to your button:

Sub CreateSheet()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, desWS As Worksheet, rng As Range, lRow As Long
    If Not Evaluate("isref('" & "Description" & "'!A1)") Then
        Set desWS = Sheets.Add(after:=Sheets(Sheets.Count))
        With ActiveSheet
            .Name = "Description"
            .Range("A1").Resize(, 2).Value = Array("Description", "PCS")
        End With
    Else
        Sheets("Description").UsedRange.Offset(1).ClearContents
        Set desWS = Sheets("Description")
    End If
    For Each ws In Sheets
        If ws.Name <> "PROFORMA" And ws.Name <> "Description" Then
            With ws
                If .Range("E" & .Rows.Count).End(xlUp).Row > 12 Then
                    For Each rng In .Range("E13", .Range("E" & .Rows.Count).End(xlUp))
                        If rng <> "" And IsNumeric(rng) Then
                            With desWS
                                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 2).Value = Array(rng.Offset(, -3), rng)
                            End With
                        End If
                    Next rng
                End If
                If .Range("K" & .Rows.Count).End(xlUp).Row > 12 Then
                    For Each rng In .Range("K13", .Range("K" & .Rows.Count).End(xlUp))
                        If rng <> "" And IsNumeric(rng) Then
                            With desWS
                                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 2).Value = Array(rng.Offset(, -3), rng)
                            End With
                        End If
                    Next rng
                End If
            End With
        End If
    Next ws
    Sheets("Description").Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

 

[pantakos]

Yeap! Thank you one more time !!! works perfect!

 

[pantakos]

@mumps I am trying to duplicate the above macro to work with two sheets, but I get an error at this part of code .ListObjects("orderlist").DataBodyRange.Delete
Runtime error 91, object variable or with block variable not set, but everything is set. Sometimes is working, some not