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]

@mumps hello again.

Is it possible the drop down menu to work with search? Like google, when type then make suggestions.

Here is the code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("D:D")) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Dim bottomC As Long
    bottomC = Sheets("DATA").Range("C" & Rows.Count).End(xlUp).Row
    Dim x As Long
    For x = bottomC To 2 Step -1
        If Sheets("DATA").Cells(x, 1) = Target Then
            Sheets("DATA").Cells(x, 3).Copy Cells(Target.Row + 4, Target.Row) 
           Sheets("DATA").Cells(x, 4).Copy Cells(Target.Row + 5, Target.Row)
            Sheets("DATA").Cells(x, 5).Copy Cells(Target.Row + 2, Target.Row) 
            Sheets("DATA").Cells(x, 6).Copy Cells(Target.Row + 3, Target.Row)
           Sheets("DATA").Cells(x, 10).Copy Cells(Target.Row + 6, Target.Row)
           Sheets("DATA").Cells(x, 9).Copy Cells(Target.Row + 7, Target.Row)
           Sheets("DATA").Cells(x, 14).Copy Cells(Target.Row + 1, Target.Row)
        End If
    Next x
    Application.ScreenUpdating = True
End Sub

The sample file is the same as above.

Thank you one more time.

 

[mumps]

Please note that since this is a different request, you should start a new thread,

 

[pantakos]

@mumps yes I know, but I cant delete my last post. I will create a new one. Thank you!

 

[pantakos]

@mumps Hello Again, since you are that helped me a lot to make the code working can you please help me one more time? I am following this post because the code is the same, sligtly changed
What I need is to rename the created sheet (Products) with the name of the sheets in ws , that are filled with data.

Sub BuildTemplateINm()
    Application.ScreenUpdating = False
    Dim Ws As Worksheet, desWS As Worksheet, rng As Range, lRow As Long
    Const sPw As String = "********"
    Dim oWs As Worksheet
    Dim wb As Workbook: Set wb = ThisWorkbook
    For Each oWs In ThisWorkbook.Worksheets
        oWs.Unprotect sPw
    Next oWs
    If Not Evaluate("isref('" & "Products" & "'!A1)") Then
        Set desWS = Sheets.Add(after:=Sheets(Sheets.Count))
       
        With ActiveSheet
            .Name = "Products"
            .Range("A1").Resize(, 2).Value = Array("Description", "Quantity")
        End With
    Else
       Sheets("Products").UsedRange.Offset(1).ClearContents
       Set desWS = Sheets("Products")
    End If
    For Each Ws In Sheets
        If Ws.Name <> "PROFORMA" And Ws.Name <> "ORDER LIST" And Ws.Name <> "PRODUCTS" And Ws.Name <> "DATASET" And Ws.Name <> "TOTAL OFFER" And Ws.Name <> "DATA" Then
            With Ws
                If .Range("H" & .Rows.Count).End(xlUp).Row > 12 Then
                      For Each rng In .Range("H14", .Range("H" & .Rows.Count).End(xlUp))
                        If (IsNumeric(rng.Value)) And (rng.Value <> 0) Then
                           With desWS
                                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 2).Value = Array(rng.Offset(, -6), rng)
                            End With
                        End If
                    Next rng
                End If
                If .Range("O" & .Rows.Count).End(xlUp).Row > 12 Then
                    For Each rng In .Range("O14", .Range("O" & .Rows.Count).End(xlUp))
                        If (IsNumeric(rng.Value)) And (rng.Value <> 0) Then
                            With desWS
                                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 2).Value = Array(rng.Offset(, -6), rng)
                            End With
                        End If
                    Next rng
                End If
            End With
        End If
    Next Ws
    Sheets("Products").Columns.AutoFit
    Application.ScreenUpdating = True
    For Each oWs In ThisWorkbook.Worksheets
        oWs.Protect sPw
    Next oWs
End Sub

If this cant be answered here I will create a new thread, I dont want to full the forum with new threads

Thank you !