< návrat zpět
MS Excel
Téma: Kopírování s libovolnou příponou
Zaslal/a Lugr 1.3.2022 18:17
Ahoj,
mám dotaz, pro kopírování z ext. souboru používám tento kód od "elninoslov". Problém je když se změní přípona. Jak mám zakomponovat, aby vyzkoušel všechny tři přípony?
Děkuji.
Sub Import()
Dim Cesta As String
Dim Nazev As String
Dim Soubor As String
Dim Zdroj As String
Cesta = "C:\Plocha\"
Nazev = "ZDROJ" (*.xls, * .xlsx, * .xlsm)
Soubor = Cesta & Nazev
If Dir(Soubor) = "" Then MsgBox "Soubor " & Soubor & " neexistuje!", vbCritical: Exit Sub
Zdroj = "'" & Cesta & "[" & Nazev & "]" & "List1" & "'!"
With Sheets("List1").Range("B2")
.Formula = "=IF(" & Zdroj & "B2" & "="""",""""," & Zdroj & "B2" & ")"
.Value = .Value
End With
End Sub
Anonym(1.3.2022 20:15)#052206 Nazev= "ZDROJ" (*.xls*)
citovat
r13(1.3.2022 20:31)#052207 Nápoveda:
If Len(Dir(Soubor & ".xls")) = 0 And Len(Dir(Soubor & ".xlsx")) = 0 And Len(Dir(Soubor & ".xlsm")) = 0 Then
MsgBox "Soubor " & Soubor & " neexistuje!", vbCritical
Exit Sub
Else: MsgBox "Soubor " & Soubor & " existuje!"
End Ifcitovat
Lugr(1.3.2022 20:57)#052208 r13 napsal/a:
Nápoveda:
If Len(Dir(Soubor & ".xls")) = 0 And Len(Dir(Soubor & ".xlsx")) = 0 And Len(Dir(Soubor & ".xlsm")) = 0 Then
MsgBox "Soubor " & Soubor & " neexistuje!", vbCritical
Exit Sub
Else: MsgBox "Soubor " & Soubor & " existuje!"
End If
Děkuju, ale tohle řeší ale pouze kontrolu existence souboru nikoliv samotný import (vzorec)
citovat
r13(2.3.2022 6:35)#052210 Iste... Myslel som, že zvyšok si už budeš vedieť, na základe nápovedy, upraviť.
OK... Zvyšok Tvojho pôvodne uvedeného kódu funguje správne?
citovat
r13(2.3.2022 7:59)#052211 Sub Import()
Dim Cesta As String
Dim Nazev As String
Dim Soubor As String
Dim Zdroj As String
Dim Pripona As String
Cesta = "C:\Plocha\"
Nazev = "ZDROJ"
Soubor = Cesta & Nazev
If Len(Dir(Soubor & ".xls")) = 0 And Len(Dir(Soubor & ".xlsx")) = 0 And Len(Dir(Soubor & ".xlsm")) = 0 Then
MsgBox "Soubor " & Soubor & " neexistuje!", vbCritical
Exit Sub
Else
If Len(Dir(Soubor & ".xls")) <> 0 Then Pripona = "xls"
If Len(Dir(Soubor & ".xlsx")) <> 0 Then Pripona = "xlsx"
If Len(Dir(Soubor & ".xlsm")) <> 0 Then Pripona = "xlsm"
End If
Zdroj = "'" & Cesta & "[" & Nazev & "." & Pripona & "]" & "List1" & "'!"
With Sheets("List1").Range("B2")
.Formula = "=IF(" & Zdroj & "B2" & "="""",""""," & Zdroj & "B2" & ")"
.Value = .Value
End With
End Subcitovat
Lugr(2.3.2022 8:17)#052212 Teď si tady nad tím lámu hlavu.
Děkuji funguje super.
citovat