Salvataggio dati particolare

Sub unica_riga()

Dim arr() As Variant
Dim r As Long, c As Long
Dim stringa As String

r = Range("A1", Range("A1").End(xlDown)).Cells.Count

c = Range("A1", Range("A1").End(xlToRight)).Cells.Count
 
ReDim arr(0 To r, 0 To c)
 
For r = LBound(arr, 1) To UBound(arr, 1)
    For c = LBound(arr, 2) To UBound(arr, 2)
        If ActiveSheet.Range("A1").Offset(r, c) = "" Then
        Else
            stringa = stringa & ActiveSheet.Range("A1").Offset(r, c)
        End If
        ActiveSheet.Range("A19") = stringa
    Next c

Next r
End Sub

Sub unica_riga_tante_colonne()

Dim arr() As Variant
Dim r As Long, c As Long, d As Long, col As Long
Dim stringa As String
Dim sh As Worksheet

'============================================
'nel range A19 la stringa con tutti i valori
' in riga 20 i valori per colonna

'============================================
Set sh = ActiveSheet

With sh

        r = Range("A1", Range("A1").End(xlDown)).Cells.Count
        
        c = Range("A1", Range("A1").End(xlToRight)).Cells.Count
         
        ReDim arr(0 To r, 0 To c)
        
         
        For r = LBound(arr, 1) To UBound(arr, 1)
            For c = LBound(arr, 2) To UBound(arr, 2)
                
                arr(r, c) = ActiveSheet.Range("A1").Offset(r, c)
                If ActiveSheet.Range("A1").Offset(r, c) = "" Then
                Else
                
                    stringa = stringa & ActiveSheet.Range("A1").Offset(r, c)
                End If
                ActiveSheet.Range("A19") = stringa
                
            Next c
          
        Next r
        
        col = 1
        
        For r = LBound(arr, 1) To UBound(arr, 1)
            For c = LBound(arr, 2) To UBound(arr, 2)
            
                arr(r, c) = ActiveSheet.Range("A1").Offset(r, c)
                
                If ActiveSheet.Range("A1").Offset(r, c) = "" Then
                Else
                
                    Cells(20, col) = ActiveSheet.Range("A1").Offset(r, c)
                End If
                
              col = col + 1
            Next c
         
        Next r
        
        For d = Range("A20", Range("A1").End(xlToRight)).Cells.Count To 1 Step -1
            
            If Cells(20, d).Value = "" Then
                Cells(20, d).Delete Shift:=xlToLeft
            End If
            
        Next d
        
End With
Set sh = Nothing

End Sub

Sub nuovo()
Dim rng, x, r, tmp
  
r = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ActiveSheet.Range("A1:I" & r)

For Each x In rng
    tmp = tmp & x & ";"
Next x
tmp = Mid(tmp, 1, Len(tmp) - 1)
Range("P1") = tmp
End Sub

Sub espandi()
Dim r, c, c1, d, x, k

k = Split(Cells(1, 16), ";")
r = 1: c = 1
For x = 0 To UBound(k)
  Cells(r, c) = k(x)
  c = c + 1
  If c = 10 Then c = 1: r = r + 1
Next x
End Sub