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

Příspěvky uživatele

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

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

Ahoj chtěl bych Vás požádat o pomoc. Mám mimo jiné hodnocení dodávaných dílů, je ohodnotit podle kriticity.

Kritéria jsou nový dodavatel, unikátní forma, unikátní technologie a dodavatel pod měsícním dohledem.

v přiloženém souboru se tedy každý díl hodnotí 5-ti hodnoceními ANO nebo NE (sloupec F až J). Po vyplnění bych potom potřeboval doplnit do sloupce K rozhodnutí dle následujících pravidel.

Když vše ze sloupců F až J bude NO - sloupec K bude písmeno C

Když New Supplier (sloupec F)bude YES - sloupec K bude písmeno A

Když Unique tooling (sloupec H) bude YES - sloupec K bude písmeno A

A když New/unique technology nebo Supplier under monitoring bude YES, tak sloupec K bude B

S tím, že poslední je pravidlo, že pokud by by jakýkolic sloupec F nebo H měl YES, automaticky to A, nehledě na to, co říkají ostatní sloupce.

Pokud cokoliv ostatní bude YES krom (F nebo H) tak automaticky to bude B a pokud vše bude NO, pak automaticky to bude C

Snad jsem to vysvětlil srozumitelně.

Děkuji V8m

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse