Inserimento riga e creazione file

Hai un problema con Excel?

Nuova discussione

Inserimento riga e creazione file
di Dont_go_away (utente non iscritto) data: 23/10/2015 13:32:02
iao a tutti!
Sono nuovo del mondo vba e cerco qualcuno in grado di aiutarmi con questa macro con cui sto lottando da una settimana.

Praticamente ho un cartella contenente tre fogli, ognuno dei quali ha una tabella che rappresenta le presenze le consegne e i resi mensili (diciamo mese1, mese2,mese3) .
Nella colonna A c'è l'elenco dei nomi, mentre nelle altre ci sono i giorni del mese, con due colonne finali che riportano rispettivamente il totale delle presenze e le note.

La macro dovrebbe, per ogni nome, creare un file e copiarci al suo interno la parte di tabella relativa al nome e , nel caso di aggiunta di un nuovo nome , creare il file con il nome appena aggiunto.

Esempio:
NOME. 1 2 3 4 5 6...31 TOTALE NOTE
Federico 8 8 8 8....8 150
Consegne 3 6 5 2.....7 80
Resi 1 2 3 4....3 20
Roberto 8 8 8 6....8 140
Consegne 5 3 9 7....6 50
Resi 1 2 5 4....7 30

In questo esempio la macro dovrebbe creare 2 file, il primo , di tre fogli (mese1, mese2, mese3) , con dentro tutte le informazioni riguardanti Federico, il secondo tutte le informazioni riguardanti Roberto.

Spero che qualcuno riesca a darmi una mano
Grazie!
di Marius44 data: 23/10/2015 13:58:21
Premesso che è buona norma allegare sempre un file, per capirne la struttura, con i propri tentativi ed il risultato attesi, non mi sembra corretto postare la stessa domanda in Forum diversi quando ti ho già dato la risposta ieri su altro Forum (e non hai pensato di darmi riscontro , nè positivo nè negativo)!

Ciao,
Mario
di Dont_go_away (utente non iscritto) data: 23/10/2015 15:21:29
Scusami, hai ragione, ma non ho avuto ancora modo di vedere la tua macro perché dal cellulare non me la apre e il PC dell'ufficio neanche. Nel weekend, a casa, l'avrei aperta e ti avrei risposto.
Nel frattempo, siccome mi sembrava irrispettoso risponderti senza aver visto la macro, volevo avere più aiuti possibili e quindi l'ho chiesto anche qui, dove ho visto che c'è il form per l'inserimento del codice, facilmente leggibile nche da cellulare).
Per lo stesso motivo non ho potuto inserire neanche il codice, dal cellulare sarebbe un po' complicato .

In ogni casi cusami ancora per la maleducazione.

di dont_go_away (utente non iscritto) data: 25/10/2015 13:12:52
Ciao a tutti, scusate ancora se vi rompo le scatole, ma volevo farvi vedere quello che ero riuscito a fare finora, in modo che magari riuscivate piu' facilmente a darmi una mano.

Vi allego l'esempio di macro che sono riuscito a realizzare finora, il problema e' che il codice e' molto lungo e ripetitivo perche' e' fatto con intervalli fissi e non va bene, perche' nel file principale, in futuro, verranno aggiunti altri nomi e altri fogli (un foglio per mese).
I problemi principali che incontro sono: non riesco a fare un ciclo per creare i files e non riesco a fare un ciclo che mi permetta di controllare se aggiungo dei nomi all'elenco principale e quindi non mi crea altri files.

Grazie ancora dell'aiuto [SM=g27817]

Sub Prova_macro()
    
 Application.ScreenUpdating = False 'disattiva passaggio da finestra ad altra finestra
    Windows(1).Activate
    numfogli = Sheets.Count 'imposto il numero di fogli totali
    'ciclo per copiare i nomi dei fogli nel nuovo file
    Workbooks.Add
    j = 1
    k = 1
    For i = 1 To numfogli - 1
    Worksheets(k).Name = Workbooks("esempio.xlsm").Sheets(j).Name
    j = j + 1
    k = k + 1
    Sheets.Add after:=ActiveSheet
    Next
    Application.DisplayAlerts = False
    Worksheets(4).Delete
    ActiveWorkbook.SaveAs "C:Macroalessandro.xlsx"
    
    'ciclo che copia gli attributi del nome sul nuovo file per tutti i fogli
    For indiceFoglio = 1 To numfogli - 1
    Application.Goto Workbooks("esempio.xlsm").Sheets(indiceFoglio).Range("A1:AH1")
    Selection.Copy
    Application.Goto Workbooks("alessandro.xlsx").Sheets(indiceFoglio).Range("A1")
    ActiveSheet.Paste
    Columns("A").EntireColumn.AutoFit
    Application.Goto Workbooks("esempio.xlsm").Sheets(indiceFoglio).Range("A2:AH4")
    Selection.Copy
    Application.Goto Workbooks("alessandro.xlsx").Sheets(indiceFoglio).Range("A2")
    ActiveSheet.Paste
    Columns("A").EntireColumn.AutoFit
    Next
    ActiveWindow.Close True

    Windows(1).Activate
    numfogli = Sheets.Count
    Workbooks.Add
    j = 1
    k = 1
    For i = 1 To numfogli - 1
    Worksheets(k).Name = Workbooks("esempio.xlsm").Sheets(j).Name
    j = j + 1
    k = k + 1
    Sheets.Add after:=ActiveSheet
    Next
    Application.DisplayAlerts = False
    Worksheets(4).Delete
    ActiveWorkbook.SaveAs "C:Macrofabrizio.xlsx"
    For indiceFoglio = 1 To numfogli - 1
    Application.Goto Workbooks("esempio.xlsm").Sheets(indiceFoglio).Range("A1:AH1")
    Selection.Copy
    Application.Goto Workbooks("fabrizio.xlsx").Sheets(indiceFoglio).Range("A1")
    ActiveSheet.Paste
    Columns("A").EntireColumn.AutoFit
    Application.Goto Workbooks("esempio.xlsm").Sheets(indiceFoglio).Range("A2:AH4")
    Selection.Copy
    Application.Goto Workbooks("fabrizio.xlsx").Sheets(indiceFoglio).Range("A2")
    ActiveSheet.Paste
    Columns("A").EntireColumn.AutoFit
    Next
    ActiveWindow.Close True
    
    'copia nomi in setting
    Sheets(1).Activate
    Set area = Worksheets(1).Range(Cells(2, 1), Cells(2, 1).End(xlDown))
    n = area.Rows.Count
    i = 2
    For r = 2 To n Step 3
        
        Sheets(4).Cells(i, 1) = Sheets(1).Cells(r, 1)
        Columns("A:A").EntireColumn.AutoFit
        Worksheets(1).Activate
        i = i + 1
        
    Next
    Sheets(4).Activate
    Range(Cells(2, 1), Cells(2, 1).End(xlDown)).Select
    ActiveWorkbook.Worksheets(4).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(4).Sort.SortFields.Add Key:=Range("A2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(4).Sort
        .SetRange Range(Cells(2, 1), Cells(2, 1).End(xlDown))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    'copia nomi file in riepilogo e ordinamento alfabetico
    Sheets(4).Activate
    Dim fso As New FileSystemObject
    Dim GF As Folder
    Dim F1 As File
    Dim percorso, ricerca
    percorso = "C:Macro"
    ricerca = "xlsx"
    Range("b2") = ricerca
    Set GF = fso.GetFolder(percorso)
    r = 1
    For Each F1 In GF.Files
        If InStr(1, F1.Name, ricerca, vbTextCompare) Then
            r = r + 1
            Cells(r, 2) = F1.Name
            Columns("B").EntireColumn.AutoFit
        End If
    Next
    
        Sheets(4).Activate
        Range(Cells(2, 2), Cells(2, 2).End(xlDown)).Select
        ActiveWorkbook.Worksheets(4).Sort.SortFields.Clear
        ActiveWorkbook.Worksheets(4).Sort.SortFields.Add Key:=Range("B2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(4).Sort
        .SetRange Range(Cells(2, 2), Cells(2, 2).End(xlDown))
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    'copia nome mesi e fogli in riepilogo
Sheets(1).Activate
    Set area = Worksheets(1).Range(Cells(2, 1), Cells(2, 1).End(xlDown))
    n = area.Count / 3
    r = 2
    c = 5
    For i = 1 To n
        For j = 1 To 3
        Sheets(4).Cells(r, c) = Sheets(j).Name
        c = c + 1
        Next
        r = r + 1
        c = 5
    Next
    
    'copia nomi fogli mesi in riepilogo
    r = 2
    For i = 1 To n
    Sheets(4).Activate
    ActiveSheet.Range(Cells(r, c), Cells(r, c).End(xlToRight)).Select
    Selection.Copy
    Sheets(4).Cells(r, c + (j - 1)).Activate
    ActiveSheet.Paste
    r = r + 1
    Next
    Sheets(4).Activate
    
End Sub

Vuoi Approfondire?