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

 

[mumps]

See if this does what you want:

Sub BuiltIT()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, desWS As Worksheet, rng As Range, lRow As Long
    Set desWS = Sheets("PROFORMA")
    With desWS
        .ListObjects("Table5").DataBodyRange.Delete
        .Range("E15").Formula = "=C15*D15"
        .Rows(16 & ":" & Sheets("PROFORMA").Rows.Count).Delete
    End With
    For Each ws In Sheets(Array("AUDIO", "AUDIO2"))
        With ws
            For Each rng In .Range("E2", .Range("E" & .Rows.Count).End(xlUp))
                If 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
            For Each rng In .Range("K2", .Range("K" & .Rows.Count).End(xlUp))
                If 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 With
    Next ws
    desWS.Rows(15).Delete
    Application.ScreenUpdating = True
End Sub

 

[pantakos]

@mumps Yes that do the job, but by mistake I uploaded the wrong sample.

Here is the correct one, using tables.
As you can see I need to place sheet name, when the insert occurs etc.


Sample10

Thank you for your effort

 

[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
        .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
                For Each rng In .Range("E13", .Range("E" & .Rows.Count).End(xlUp))
                    If 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
                For Each rng In .Range("K13", .Range("K" & .Rows.Count).End(xlUp))
                    If 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 With
        End If
    Next ws
    desWS.Rows(15).Delete
    Application.ScreenUpdating = True
End Sub

 

[pantakos]

Unfortenetly it doest work proper. Thank you for your time and effort.

The basic idea is the check all column E and K , and check if there is a numeric value and only, If yes then Copy Price per Day (column D or H depends the PCS value where it is) at Proforma Column C ,
then copy E & K to column D of Proforma and copy B & H to column B at proforma.

And copy the sheet name at B at the start of the check at each sheet.

Please take a look at the image I attach to see the result that your script does .

Thank you

 

[pantakos]

Can this code modified to use two columns ?

Sub BuildIT()
Dim ws As Variant, sht As Variant
Dim i As Long, lr As Long, nr As Long, c As Long
Dim cell As Range
Application.ScreenUpdating = False
' Set array of worksheet names to copy from
ws = Array("AUDIO", "AUDIO1", "AUDIO2)
' Array of columns to check
sht = Array("E")   <----  AND HERE ADD ALSO "M" COLUMN AND MAKE THE NECCESARY COPIES OF CELLS ETC
nr = 15


'On Error Resume Next
Sheets("PROFORMA").ListObjects("Table5").DataBodyRange.Delete
Sheets("PROFORMA").Range("E15").Formula = "=C15*D15"
Sheets("PROFORMA").Rows(16 & ":" & Sheets("PROFORMA").Rows.Count).Delete

' Loop through all sheets in sheets array
For i = LBound(ws) To UBound(ws)
' Loop through all columns in the column array
For c = LBound(sht) To UBound(sht)
' Find last row in column with data
    With Sheets(ws(i))
        Sheets("PROFORMA").Cells(nr, "B") = Sheets(ws(i)).Name
        Sheets("PROFORMA").Cells(nr, "B").Interior.Color = 65535  ' add Newline
        lr = .Cells(Rows.Count, sht(c)).End(xlUp).Row
        ' Loop through all cells in column
        For Each cell In .Range(.Cells(1, sht(c)), .Cells(lr, sht(c)))
        ' Check to see if value is numeric and not 0
              If (IsNumeric(cell.Value)) And (cell.Value <> 0) Then
                nr = nr + 1
            ' Copy Description
            .Cells(cell.Row, "B").Copy
            Sheets("PROFORMA").Cells(nr, "B").PasteSpecial Paste:=xlPasteValues

            Sheets("PROFORMA").Cells(nr, "B").Interior.Pattern = xlNone
            ' Copy Price
            .Cells(cell.Row, "D").Copy
            Sheets("PROFORMA").Cells(nr, "C").PasteSpecial Paste:=xlPasteValues

            ' Copy Quantity
            .Cells(cell.Row, "H").Copy
            Sheets("PROFORMA").Cells(nr, "D").PasteSpecial Paste:=xlPasteValues


           
            ' Increment nr counter
            End If
        Next cell
    End With
Next c
nr = nr + 1
Next i

Application.ScreenUpdating = True

MsgBox "Done! Invoice created."

End Sub

 

[mumps]

This is what I got when I tested the macro below:

SAMPLE10.xlsm
	B	C	D	E
14	DESCRIPTION	PRICE	PCS	TOTAL
15	AUDIO			0
16	PRODUCT 1	10.00 €	10	100
17	PRODUCT 3	10.00 €	12	120
18	AUDIO3			0
19	PRODUCT210	100.00 €	20	2000
20	PRODUCT211	100.00 €	30	3000
21	PRODUCT230	55.00 €	3	165
22	PRODUCT235	55.00 €	4	220
23	AUDIO4			0
24	PRODUCT272	55.00 €	12	660
25	PRODUCT273	55.00 €	24	1320
PROFORMA

Sub BuiltIT()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, desWS As Worksheet, rng As Range, lRow As Long
    Set desWS = Sheets("PROFORMA")
    With desWS
        .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
                    desWS.Cells(desWS.Rows.Count, "B").End(xlUp).Offset(1) = ws.Name
                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 <> "" 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 <> "" 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]

You are correct. Is it checking if it is a number ? and check all column E and K ?
Thank you !

 

[mumps]

You are very welcome.

 

[pantakos]

@mumps Oops! Something new!
Sometimes, it gives me this error (mostly of the time)

Here

Why does that?

And a last one, the name of the sheet need to be Yellow the other lines with the products no color.

Thank you again !