+ Rispondi al Thread
Visualizzazione dei risultati da 1 a 3 su 3

Discussione: Trasposizione di colonne con valori e esportazione csv

  1. #1
    AndryFox non è in linea Novello
    Post
    36

    Trasposizione di colonne con valori e esportazione csv

    Ciao a tutti,

    Ho un file con molte righe dove in specifiche colonne (15 colonne di quantità per ogni riga), un operatore inserisce o meno una quantità.

    Dovrei fare un'estrazione in .csv con separatore ';' di ogni riga ripetuta per il numero di celle di quantità inserite.

    E' piu difficile da spiegare che da fare, in ogni caso smanettandoci dietro sono arrivato a farlo ma mi sembra un pò lento e non vorrei aver creato passaggi per nulla.

    Avrei bisogno di un occhio più esperto che mi consigli se ci sono vie più semplici per arrivare al risultato di quello che ho costruito io.

    Il file lo si può trovare qui:
    Test1.xslm
    L'output dovrà essere di questo tipo:

    1;;XS;DML261R
    2;;S;DML261R


    Grazie a tutti

  2. #2
    L'avatar di AntonioG
    AntonioG non è in linea Moderatore Globale Ultimo blog: Commodore 64 e Codemotion
    Luogo
    Roma
    Post
    16,768
    Blogs
    5
    Così costringi a scaricare il file per vedere il codice di cui parli.

    Perché non lo hai mostrato qui commentandolo dove lo ritieni utile ?
    Avvisi generali e importanti, a pena CHIUSURA thread e/o BAN
    Il crossposting è vietato.
    Le richieste di "pappa pronta" sono vietate.
    Utilizzate i tag CODE per il codice.
    Leggere il Regolamento per chiarimenti PRIMA di creare nuovi thread.
    Utilizzare sempre i PM per comunicare con i moderatori.
    Non mi contattate in PM per problemi di software, usate il forum

  3. #3
    AndryFox non è in linea Novello
    Post
    36
    Quote Originariamente inviato da AntonioG Visualizza il messaggio
    Così costringi a scaricare il file per vedere il codice di cui parli.
    Perché non lo hai mostrato qui commentandolo dove lo ritieni utile ?
    Ciao Antonio, pensavo fosse più comodo vederlo direttamente in azione poichè non è troppo semplice, in ogni caso lo copio pure qui:

    codice:
    Sub TraspostaTaglie()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim InputRange As Range, OutputCell As Range, Ur As Long, Uc As Long
    
    ' Calcolo numero delle righe da copiare
    Ur = ActiveWorkbook.Sheets("DONNA").Range("B" & Rows.Count).End(xlUp).Row
    Uc = ActiveWorkbook.Sheets("DONNA").Cells(1, Columns.Count).End(xlToLeft).Column
    
    J = 2   ' Riga d'inizio taglie
    K = 2   ' Riga d'inizio altre colonne
    Nc = 17 ' N° Colonne taglie da trasportare
    Ri = 0
    
    ' Svuoto valori e filtri del "Foglio1"
    Worksheets("Foglio1").Activate
    Range("B2:BH30000").Select
    Selection.ClearContents
    
    ' Sul foglio "DONNA" elimino filtri impostati e filtro tutte le celle in cui il campo "COD.ART" non è vuoto
    Worksheets("DONNA").Activate
    Cells.Select
    ActiveSheet.Range("$A$16:$BV$1045629").AutoFilter Field:=5, Criteria1:="<>"
    
    ' Seleziono l'intervallo dei valori che devo copiare da foglio "DONNA" e trasportare nel "Foglio1"
    Set InputValori = ActiveWorkbook.Sheets("DONNA").Range(Cells(17, 7), Cells(Ur, 23))
    Set OutputValori = ActiveWorkbook.Sheets("Foglio1").Range("B2")
    For Each cel In InputValori
        OutputValori.Value = cel.Value
        Set OutputValori = OutputValori.Offset(1, 0)
    Next
    
    ' Per ogni riga nel foglio "DONNA" copio e trasporto nel "Foglio1" le intestazioni
    For i = 2 To Ur
        Worksheets("DONNA").Activate
        Range("G16:U16").Select         ' Range di colonne taglie
        Selection.Copy
        Worksheets("Foglio1").Activate
        Range("D" & J).Select           ' Copia nella colonna B
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        Application.CutCopyMode = False
    
    ' Per ogni intestazione trasportata, copio e ripeto i valori di altre colonne
        Ri = Nc + i
        For e = 1 To Nc
            Worksheets("DONNA").Activate
            Cells(Ri, 5).Select ' Range di colonne da copiare per ogni taglia
            Selection.Copy
            Worksheets("Foglio1").Activate
            Range("E" & K).Select                       ' Copia dalla colonna E
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
            Application.CutCopyMode = False
            
            Worksheets("DONNA").Activate
            Range(Cells(Ri, 24), Cells(Ri, 76)).Select ' Range di colonne da copiare per ogni taglia
            Selection.Copy
            Worksheets("Foglio1").Activate
            Range("F" & K).Select                       ' Copia dalla colonna E
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
            Application.CutCopyMode = False
            
        K = K + 1
        Next e
        
        J = J + Nc
    Next i
     
    ' Esporto il file in formato .010
    Call Esporta
    
    Worksheets("DONNA").Activate
    ActiveSheet.ShowAllData
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    End Sub
    Una volta ricreata la tabella nel Foglio1 come desiderato, nella colonna A faccio un Concatena solo di quelle righe che hanno una quantità e delle colonne cche mi interessano separate da ;


    codice:
    Sub Esporta()
    Dim MyFile As String
    Dim Stringa As String
    Dim FileSystemObj As Object
    Dim TextStreamFileObj As Object
    Dim i As Integer
    
    Ur = ActiveWorkbook.Sheets("Foglio1").Range("A" & Rows.Count).End(xlUp).Row
    
    i = 0
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Worksheets("Foglio1").Activate
    
    MyFile = "C:\Temp\Esportazione.010"
    
    Set FileSystemObj = CreateObject("Scripting.FileSystemObject")
    Set TextStreamFileObj = FileSystemObj.CreateTextFile(MyFile, True)
    
    For i = 2 To Ur
    If Len(Cells(i, 1).Value) > 0 Then
        Stringa = Cells(i, 1).Value
        TextStreamFileObj.Writeline (Stringa)
    End If
    Next i
    
    TextStreamFileObj.Close
    
    Set mioRange = Nothing
    Set FileSystemObj = Nothing
    Set TextStreamFileObj = Nothing
    
    Worksheets("Donna").Activate
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    End Sub

+ Rispondi al Thread

Permessi di invio

  • Non puoi inserire discussioni
  • Non puoi inserire repliche
  • Non puoi inserire allegati
  • Non puoi modificare i tuoi messaggi