mettere in colonna tutte le righe in base al valore di A

[c_ros]

Ciao a tutti!!!Eccomi di nuovo qui a chiedervi aiuto... (prima o poi imparerò a programmare in VBA.
Ho una tabella con 4809 righe e vorrei che tutti valori presenti nelle righe da B a AE vengano messi in colonna a lato del rispettivo valore presente in A e quindi per ogni elemento A ripetere tale elemento tante volte quante sono gli elementi delle righe...Lo so è un pò contorta la cosa...l'esempio è questo:

L0 263A 1048T 3516a 5442C 6185C 9042T 9347G 10589A 12007A 12720G
L0a'b'f'k 189G 4586C 9818T 16172C
L0a'b'f 73A 185A 195T 2245G 5603T 11641G 15136T 15431A

e vorrei ottenere questo:

L0 263A
L0 1048T
L0 3516a
L0 5442C
L0 6185C
L0 9042T
L0 9347G
L0 10589A
L0 12007A
L0 12720G
L0a'b'f'k 189G
L0a'b'f'k 4586C
L0a'b'f'k 9818T
L0a'b'f'k 16172C
L0a'b'f 73A
L0a'b'f 185A
L0a'b'f 195T
L0a'b'f 2245G
L0a'b'f 5603T
L0a'b'f 11641G
L0a'b'f 15136T
L0a'b'f 15431A
vi allego il file di partenza e la bozza del file che vorrei ottenere, ecco i link:
http://rapidshare.com/share/BD2402760EB ... 082F88F735
http://rapidshare.com/share/D9C6F10FDA0 ... 00FAE67600

Grazie in anticipo a tutti!!!

[ricky53]

Ciao,
prova con questo esempio che va copiato in un "Modulo" ed eseguito con "F5".

Prima di eseguire la macro fai una copia del tuo file!!!


Nella macro ho supposto che i dati da copiare fossero sul "Foglio1", che partissero dalla prima riga e dalla colonna "A".
Eseguendo la macro la copia dei dati verrà fatta sul "Foglio2"

Codice: Seleziona tutto

Option Explicit

Sub Copia_e_Trasponi()
    Dim I As Long, J As Long, UR As Long, CC As Integer, RR As Integer, WS_In As Worksheet, WS_Out As Worksheet
    Dim Inizio As Double
   
    Application.ScreenUpdating = False
    Inizio = Timer
    Set WS_In = Sheets("Foglio1")
    Set WS_Out = Sheets("Foglio2")
   
    UR = WS_In.Range("A" & Rows.Count).End(xlUp).Row
   
    WS_Out.Select
    For I = 1 To UR
        J = WS_Out.Range("A" & Rows.Count).End(xlUp).Row + 1
        CC = WS_In.Range("B" & I).End(xlToRight).Column
        WS_In.Range(WS_In.Cells(I, "B"), WS_In.Cells(I, CC)).Copy
        WS_Out.Cells(J, "B").Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
        RR = WS_Out.Range("B" & Rows.Count).End(xlUp).Row
        WS_In.Cells(I, "A").Copy Destination:=WS_Out.Cells(J, "A")
        WS_Out.Cells(J, "A").Copy
        WS_Out.Range(WS_Out.Cells(J + 1, "A"), WS_Out.Cells(RR, "A")).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
    Next I
    Set WS_In = Nothing
    Set WS_Out = Nothing
    Application.ScreenUpdating = True

    MsgBox "E' stata effettuata la copia dei dati in:  '" & Format(Timer - Inizio, "0.000") & "'   sec."
End Sub

Prova e ... sono QUI

[c_ros]

Grazie grazie grazie!!!funziona benissimo!!!:)

[PcBase]

Ciao
Provate con:
Nota: Il numero dei valori estratti non corrisponde con il codice precedente

Codice: Seleziona tutto

Option Explicit

Sub Forum_Test()

    Dim varData()               As Variant
    Dim varFinalData()          As Variant
    Dim lngTotalDataCell        As Long
    Dim lngLoop                 As Long
    Dim lngLoop1                As Long
    Dim lngCount                As Long
    Dim Txt                     As String
    Const strDataRange          As String = "A1:AE4578"
    Const strDataShtName        As String = "Foglio1"
    Const DestinationShtName    As String = "Foglio2"
    Const strOutDataCell        As String = "A1"
   
    With ThisWorkbook.Worksheets(strDataShtName)
        varData = .Range(strDataRange).Value
        lngTotalDataCell = WorksheetFunction.CountA(.Range(strDataRange))
        ReDim varFinalData(1 To lngTotalDataCell, 1 To 2)
        lngCount = 0
        For lngLoop = LBound(varData) To UBound(varData)
            Txt = varData(lngLoop, LBound(varData))
            For lngLoop1 = LBound(varData) + 1 To UBound(varData, 2)
              If lngLoop1 > 2 Then
                If LenB(Trim(varData(lngLoop, lngLoop1))) Then
                    lngCount = lngCount + 1
                    varFinalData(lngCount, 1) = Txt
                    varFinalData(lngCount, 2) = varData(lngLoop, lngLoop1)
                End If
              Else
                lngCount = lngCount + 1
                varFinalData(lngCount, 1) = Txt
                varFinalData(lngCount, 2) = varData(lngLoop, lngLoop1)
              End If
            Next lngLoop1
        Next lngLoop
    End With
    Worksheets(DestinationShtName).Range("A1").Resize(UBound(varFinalData), UBound(varFinalData, 2)).Value = varFinalData
    Erase varData
    Erase varFinalData
    lngTotalDataCell = Empty
    lngLoop = Empty
    lngLoop1 = Empty
    lngCount = Empty

End Sub

[ricky53]

Ciao,
vero PCBase non sapevo di alcune condizioni sui codici che potevano esistere senza dati nella colonna "B".

Ecco il codice modificato

Codice: Seleziona tutto

Option Explicit

Sub Copia_e_Trasponi()
    Dim I As Long, J As Long, UR As Long, CC As Integer, RR As Integer, WS_In As Worksheet, WS_Out As Worksheet
    Dim Inizio As Double
   
    Application.ScreenUpdating = False
    Inizio = Timer
    Set WS_In = Sheets("Foglio1")
    Set WS_Out = Sheets("Foglio2")
   
    UR = WS_In.Range("A" & Rows.Count).End(xlUp).Row
   
    WS_Out.Select
    For I = 1 To UR
        J = WS_Out.Range("A" & Rows.Count).End(xlUp).Row + 1
        CC = WS_In.Cells(I, Columns.Count).End(xlToLeft).Column ' <<<===== Modificata
' Aggiunte
        If CC > 1 Then
            WS_In.Range(WS_In.Cells(I, "B"), WS_In.Cells(I, CC)).Copy
            WS_Out.Cells(J, "B").Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                False, Transpose:=True
        End If
' Aggiunte
        RR = WS_Out.Range("B" & Rows.Count).End(xlUp).Row
        WS_In.Cells(I, "A").Copy Destination:=WS_Out.Cells(J, "A")
        If CC > 2 Then ' <<<====== Aggiunta
            WS_Out.Cells(J, "A").Copy
            WS_Out.Range(WS_Out.Cells(J + 1, "A"), WS_Out.Cells(RR, "A")).Select ' Funzionante !!!
            ActiveSheet.Paste
        End If
        Application.CutCopyMode = False
    Next I
    Set WS_In = Nothing
    Set WS_Out = Nothing
    Application.ScreenUpdating = True

    MsgBox "E' stata effettuata la copia dei dati in:  '" & Format(Timer - Inizio, "0.000") & "'   sec."
End Sub


Andrebbe ottimizzato per velocizzarlo introducendo l'utilizzo delle ARRAY, se l'utilizzo non è molto frequente si possono aspettare i circa "10" secondi per avere l'elaborazione dei dati.

[Anthony47]

Se la velocita' e' un problema si puo' provare questa versione di macro, dovrebbe essere abbastanza piu' rapida:

Codice: Seleziona tutto

Sub roscli()
Dim LBd2 As Long, myData As String, myOutput As String, myTim As Single, UBd2 As Long
Dim CCount As Long, RCount As Long, VArr, RArr(1 To 100000, 1 To 2)
Dim I As Long, CRC As Long, J As Long, NextR As Long
'
myData = "Foglio1"      '<< Foglio con i dati di origine
myOutput = "Foglio2"    '<< Foglio in cui si crea l' output desiderato
'
Sheets(myData).Select
myTim = Timer
Sheets(myOutput).Range("A:C").ClearContents      ' VEDI TESTO
CCount = ActiveSheet.UsedRange.Columns.Count - 1
RCount = Cells(Rows.Count, 1).End(xlUp).Row
'
VArr = Range("A1").Resize(RCount, CCount + 1).Value
UBd2 = UBound(VArr, 2)
LBd2 = LBound(VArr, 2) + 1
'
For I = LBound(VArr, 1) To UBound(VArr, 1)
    CRC = 0
    'C_R_Counter:
    For J = LBound(VArr, 2) + 1 To UBd2
        If VArr(I, J) <> "" Then
            CRC = CRC + 1
        Else
            Exit For
        End If
    Next J
'
'
'distribuisci in RArr
    If NextR < 2 Then NextR = 2
    If CRC > 0 Then
        For J = LBd2 To LBd2 + CRC - 1
            RArr(NextR + J - LBd2, 1) = VArr(I, 1)
            If VArr(I, J) <> "" Then
                RArr(NextR + J - LBd2, 2) = VArr(I, J)
            Else
                Exit For
            End If
        Next J
    DoEvents
    Else
        RArr(NextR, 1) = VArr(I, 1)
    End If
'Aggiorna NextR:
    If CRC > 0 Then NextR = NextR + CRC Else NextR = NextR + 1
    DoEvents
Next I
'dump RArr:
Sheets(myOutput).Range("A1").Resize(NextR, 2).Value = RArr
Sheets(myOutput).Range("A1:B1").Value = Array("Lista1", "Lista2")  '<< Le intestazioni
MsgBox ("Completato in ... " & (Timer - myTim))
End Sub

Le istruzioni marcate << vanno personalizzate; si tenga presente che le colonne A:C del foglio di output saranno RIPULITE SENZA PREAVVISO a inizio macro.

Il codice suggerito gestisce max 100mila righe di output.

Ciao a tutti.

[PcBase]

In merito a:

Il codice suggerito gestisce max 100mila righe di output.

Anthony Nel codice che ho proposto in precedenza si può utilizzare..

Codice: Seleziona tutto

lngTotalDataCell = WorksheetFunction.CountA(.Range(strDataRange))
        ReDim varFinalData(1 To lngTotalDataCell, 1 To 2)

E otteniamo la necessaria dimensione

[Anthony47]

E' vero, in quel modo si evita il dimensionamento a caso di RArr() su 100mila righe, anche se non si ottiene i dimensionamento preciso...
Nel mio codice va modificata la Dim iniziale di RArr e inserita la Redim; che corrisponde a queste variazioni:

Codice: Seleziona tutto

Sub roscli()
Dim LBd2 As Long, myData As String, myOutput As String, myTim As Single, UBd2 As Long
Dim CCount As Long, RCount As Long, VArr, RArr()      'MODIFICATA
Dim I As Long, CRC As Long, J As Long, NextR As Long
'
myData = "Foglio1"      '<< Foglio con i dati di origine
myOutput = "Foglio2"    '<< Foglio in cui si crea l' output desiderato
'
Sheets(myData).Select
myTim = Timer
Sheets(myOutput).Range("A:C").ClearContents
CCount = ActiveSheet.UsedRange.Columns.Count - 1
RCount = Cells(Rows.Count, 1).End(xlUp).Row
ReDim RArr(1 To Application.WorksheetFunction.CountA(ActiveSheet.UsedRange), 1 To 2)    'AGGIUNTA
'
VArr = Range("A1").Resize(RCount, CCount + 1).Value
'etc etc

Vedi una riga MODIFICATA e una riga AGGIUNTA.

Ciao a tutti

[c_ros]

Siete gentilissimi!!!!grazie a tutti!!!:)