AS
AS
VBA per Microsoft Excel
Tool per creare file in copia da un modello
Pardendo da una base dati contenuta un un foglio dedicato, il presente tool consente di creare tante cartelle di Excel quanti sono i valori distinti nella colonna A:A, e contenenti tanti fogli di lavoro quanti sono i valori nella colonna B:B.
Ad esempio, una struttura tipo:
genererà 2 files, di cui il primo con 3 fogli ed il secondo con 1.
Il layout dei file creati è determinato dal modello, del quale sono una copia.
Il posizionamento di ogni singolo campo è personalizzabile, così come il nome dei file di output (ai quali verrà applicato un suffisso) e del file modello.
In allegato il tool ed un esempio estrememente semplificato di modello.
Scaricando i seguenti file accettate che vengono rilasciati così come sono, senza alcun tipo di garanzia.
Ad esempio, una struttura tipo:
| A | B | C |
|---|---|---|
| a | a | ... |
| a | b | ... |
| a | c | ... |
| b | d | ... |
Il layout dei file creati è determinato dal modello, del quale sono una copia.
Il posizionamento di ogni singolo campo è personalizzabile, così come il nome dei file di output (ai quali verrà applicato un suffisso) e del file modello.
In allegato il tool ed un esempio estrememente semplificato di modello.
Scaricando i seguenti file accettate che vengono rilasciati così come sono, senza alcun tipo di garanzia.
Codice
Public Function copy_from_model(myModel As String, myExcelName As String)
Dim wb As Workbook
Dim wbName As String
Dim Vpath As String
Dim Vfile As String
Dim Vrow As Integer
Dim myRange1 As String
Dim myRange2 As String
Dim myRange3 As String
Dim myRange4 As String
'etc...
'customize types ...
Dim myValue1 As String
Dim myValue2 As Integer
Dim myValue3 As Integer
Dim myValue4 As Integer
Set wb = ActiveWorkbook
wbName = ActiveWorkbook.Name
Set fs = CreateObject("Scripting.FileSystemObject")
Vpath = ActiveWorkbook.Path
myModel = Vpath & "\" & myModel
Vrow = 2
'customize ...
myRange1 = Cells(7, 2)
myRange2 = Cells(8, 2)
myRange3 = Cells(9, 2)
myRange4 = Cells(10, 2)
'etc...
While (wb.Sheets("data").Cells(Vrow, 1) <> "")
'customize from here ...
myValue1 = Workbooks(wbName).Sheets("data").Cells(Vrow, 3)
myValue2 = Workbooks(wbName).Sheets("data").Cells(Vrow, 4)
myValue3 = Workbooks(wbName).Sheets("data").Cells(Vrow, 5)
myValue4 = Workbooks(wbName).Sheets("data").Cells(Vrow, 6)
'etc...
If wb.Sheets("data").Cells(Vrow, 1) <> wb.Sheets("data").Cells(Vrow - 1, 1) Then
'a new value in col A:A -> create a new file
Vfile = Vpath & "\" & myExcelName & "_" & wb.Sheets("data").Cells(Vrow, 1) & ".xlsx"
fs.CopyFile myModel, Vfile, True
Workbooks.Open Vfile
End If
'same value in col A:A as the previous one -> go on adding sheets to the current file using value in col B:B
Worksheets(1).Copy After:=Worksheets(Worksheets.Count)
ActiveWindow.ActiveSheet.Name = Workbooks(wbName).Sheets("data").Cells(Vrow, 2)
ActiveWorkbook.ActiveSheet.Range(myRange1) = myValue1
ActiveWorkbook.ActiveSheet.Range(myRange2) = myValue2
ActiveWorkbook.ActiveSheet.Range(myRange3) = myValue3
ActiveWorkbook.ActiveSheet.Range(myRange4) = myValue4
'etc...
If wb.Sheets("data").Cells(Vrow, 1) <> wb.Sheets("data").Cells(Vrow + 1, 1) Then
'the next valuye in col A:A will be different -> delete the sheet-model, close and save the current file
Application.DisplayAlerts = False
'avoid prompting
Worksheets(1).Delete
Application.DisplayAlerts = True
Workbooks(myExcelName & "_" & wb.Sheets("data").Cells(Vrow, 1) & ".xlsx").Close SaveChanges:=True
End If
Vrow = Vrow + 1
Wend
MsgBox ("Esportazione terminata")
Exit Function
End Function