BUILD A SET OF DATA BASED ON SOME FILTERS

[RIC63]

Morning,

I need to analyze a lot of column -i.e. E12 ÷ AT25- and for each one


if there is only one number then the content of B84 must be copied -by paste special only value- on row 26 of that column




if there is more than one number then the contain of C84 ÷ C86 must be copied -via paste special only value- on row 26 of that column


then after each column that contain more than one number a new one must be inserted and filled with the data present in B64 ÷ B81 allways -via paste special only value-


On sheet 'Result' i show the result of the above steps

I currently use excel 2010 and also 2021

Thanks for any suggestions

[p45cal]

Try this macro which works on the ACTIVE SHEET:

Sub blah()
On Error GoTo myError
Application.ScreenUpdating = False
With Range("E11:AT25")
  For colm = .Columns.Count To 1 Step -1
    Set thiscolm = .Columns(colm)
    Select Case Application.Count(thiscolm)
      Case 0
        'nothing
      Case 1
        Range("B84").Copy
        thiscolm.Resize(1).Offset(thiscolm.Rows.Count).PasteSpecial Paste:=xlPasteValues
      Case Else
        Range("C84:C86").Copy
        thiscolm.Resize(1).Offset(thiscolm.Rows.Count).PasteSpecial Paste:=xlPasteValues
        thiscolm.Offset(, 1).EntireColumn.Insert
        Range("B64:B81").Copy
        thiscolm.Offset(, 1).PasteSpecial Paste:=xlPasteValues
    End Select
  Next colm
End With
myError:
Application.ScreenUpdating = True
End Sub

[RIC63]

good morning p45cal
thank you


the routine does exactly what I wanted, I do some testing on a larger dataset but I'm convinced it's ok


Thanks again

[snb]

It's an exercise to work with Arrays in VBA:

Sub M_snb()
  With Foglio1
    .Range("AU10:AU27").NumberFormat = "@"
    .Range("AU11:AU28") = .Range("B64:B81").Value
    .Range("E26:AT26") = "'01"
     
    sn = .Range("E8:AU32")
  End With
   
  For jj = 1 To UBound(sn, 2) - 1
    c00 = c00 & " " & jj
    If sn(1, jj) > 1 Then
      c00 = c00 & " " & UBound(sn, 2)
      sn(20, jj) = 2
      sn(21, jj) = 1
    End If
  Next
     
  sp = Application.Index(sn, [row(1:25)], Split(Trim(c00)))
  With Foglio1.Cells(100, 1).Resize(UBound(sp), UBound(sp, 2) - 1)
    .NumberFormat = "@"
    .Value = sp
  End With
End Sub

[RIC63]

good morning snb
thanks to you too for the support