• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

MS Excel

Téma: Automatické ukládání souborů do složky

Zaslal/a milos85 3.10.2019 11:04

Zdravím, měl bych dotaz. Mám zde nástroj na tvoření formulárů, které se mě po zmáčknutí tlačítka uloží do složky jako jednotlivé soubory. 3lo by přidělat, že se prvně z cílové složce vytvoří složka s aktuálním datem (například 3.10.2019) a teprve do té se uloží všechny soubory z tabulky?

zde je makro co zatím mám

Sub Create_RunRate_Forms()
Dim lngRows As Long, arrData(), i As Long, tmpWB As Workbook, strPath As String, IsOpened As Boolean, intFormat As Integer, arrPart(1 To 2, 1 To 1), bSkipReplace As Byte, strFile As String, bSave As Boolean

strPath = ThisWorkbook.Path & Application.PathSeparator

With wsSource
lngRows = .Cells(Rows.Count, 1).End(xlUp).Row - 1
If lngRows = 1 Then MsgBox "There are no data", vbCritical, "No data": Exit Sub
arrData = .Cells(2, 1).Resize(lngRows, 7).Value2
End With

Application.ScreenUpdating = False

On Error Resume Next
Set tmpWB = Workbooks("runrate-template.xls")
If tmpWB Is Nothing Then
Set tmpWB = Workbooks.Open(strPath & "runrate-template.xls")
If tmpWB Is Nothing Then MsgBox "File is missing : runrate-template.xls", vbCritical, "Missing template": GoTo ENDPROC
Else
IsOpened = True
End If

i = Len(tmpWB.Worksheets("Run at Rate").Name)
If i = 0 Then MsgBox "List is missing : Run at Rate", vbCritical, "Missing list": GoTo WBCLOSE
strPath = strPath & "RunRate Forms" & Application.PathSeparator
If Len(Dir(strPath, vbDirectory)) = 0 Then MsgBox "Path for forms is missing : " & vbNewLine & strPath, vbCritical, "Missing path": GoTo WBCLOSE
On Error GoTo 0

intFormat = IIf(Val(Application.Version) < 12, -4143, 56)

Application.DisplayAlerts = False
With tmpWB.Worksheets("Run at Rate")
For i = 1 To lngRows
strFile = strPath & arrData(i, 1) & "_" & arrData(i, 2) & ".xls"

If bSkipReplace = 0 Then
If Len(Dir(strFile)) <> 0 Then
Select Case MsgBox("Files exist :" & vbNewLine & strFile & vbNewLine & vbNewLine & "YES - Replace all" & vbNewLine & "NO - Skip all" & vbNewLine & "CANCEL - Exit procedure", vbCritical + vbYesNoCancel, "Any files exists")
Case vbYes: bSkipReplace = 1
Case vbNo: bSkipReplace = 2
Case vbCancel: Exit For
End Select
End If
End If

If bSkipReplace < 2 Then bSave = True Else bSave = Len(Dir(strFile)) = 0

If bSave Then
arrPart(1, 1) = arrData(i, 1): arrPart(2, 1) = arrData(i, 2)
.Cells(4, 4).Resize(2).Value2 = arrPart
.Cells(6, 5).Value2 = arrData(i, 7)
Erase arrPart
If Not IsEmpty(arrData(i, 3)) Then arrPart(1, 1) = arrData(i, 3)
If Not IsEmpty(arrData(i, 4)) Then arrPart(2, 1) = arrData(i, 4)
.Cells(5, 8).Resize(2).Value2 = arrPart
tmpWB.SaveAs strFile, intFormat
'DoEvents
'Application.StatusBar = "Files " & i & " / " & lngRows & " completed"
'DoEvents
End If
Next i
End With

Application.DisplayAlerts = True
'Application.StatusBar = False
WBCLOSE:
If Not IsOpened Then tmpWB.Close False
Set tmpWB = Nothing

ENDPROC:
Application.ScreenUpdating = True
End Sub

Zaslat odpověď >

---

elninoslov(3.10.2019 12:49)#044460

Je to môj kód z 26.2.2018. Myslím, že bude stačiť vložiť toto
strPath = strPath & Format(Date, "yyyy.mm.dd") & Application.PathSeparator
If Len(Dir(strPath, vbDirectory)) = 0 Then MkDir strPath
Pred riadok
Application.DisplayAlerts = Falsecitovat

milos85(4.10.2019 9:51)#044465

Super Funguje. Můžu Tě poprosit ještě o jednu věc prosím? Asi bude lepší přes email... Díkycitovat

elninoslov(6.10.2019 11:30)#044481

Iba ak to bude prkotina. Nasľuboval som už kadekomu hory-doly, a nemám kedy (často ani chuť) skoro nič urobiť ...
Pošli to na mail.citovat

milos85(7.10.2019 7:11)#044482

elninoslov napsal/a:

Iba ak to bude prkotina. Nasľuboval som už kadekomu hory-doly, a nemám kedy (často ani chuť) skoro nič urobiť ...
Pošli to na mail.

Chtěl bych Vás požádat ještě o jednu věc, zda-li by bylo možné převést tlačítkem položky z PCL právě do toho templatu KPL, který jste mi dělal, aby se zachovala funkcnost?

V zipu jsou původní soubory potřebné k převodu KPL na CIS plus je tam ještě jeden. který se jmenuje PCL_automatization_template.

Tento template má sloupce A až L a potřeboval bych následující. Aby se zase na klik (tlačítko)převedlo z PCL_automatization_template do Key Part List Creation_template následující.

Položky sloupce A do sloupce C
Položky sloupce B do sloupce B
Položky sloupce C nepřevádět nikam
Položky sloupce D převést do sloupce N
Položky sloupce E převést do sloupce D

Položky které se mají dle výše zmíněného převádet, musí být označeny ve sloupci L jako YES. Vše co bude jako NO, tak se do KPL nebude převádět.

Snad je to dostatečně srozumitelné. Ještě jednou mockrát děkuju.

Příloha: 44482_pcl_kpl_template.zip (430kB, staženo 22x)

citovat

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse