Přidej před err:
Kód: Vybrat vše
'vytvori hyp.odkaz
aRange.Hyperlinks.Add Anchor:=aRange.Cells(aIndex, 25), Address:= _
SPath & SExN, TextToDisplay:=SExN
Kód: Vybrat vše
'vytvori hyp.odkaz
aRange.Hyperlinks.Add Anchor:=aRange.Cells(aIndex, 25), Address:= _
SPath & SExN, TextToDisplay:=SExN
Kód: Vybrat vše
Sub NactiDataZAdresare()
Dim aWorkbook As Workbook, aRange As Range
Dim TWbk As String, SExN As String, SPath As String
Dim SFleFirst As Boolean, CntFFile As Integer, aIndex As Integer, MsgResponse As Byte
Dim OB1, OB2, OB3, OB4, OB5, OB6, OB7 As Boolean, OBpopisek, OBpopisek2 As Variant
'
Application.ScreenUpdating = False
' nacist parametry
Set aRange = Range("A3:AG100")
TWbk = ThisWorkbook.Name ' nazev tohoto souboru
SPath = ThisWorkbook.Path & "\" ' cesta k souborum
SExN = "*.xlsm" ' koncovka soubor
aIndex = 1 ' radek od ktereho se vkladaji data
' v katalogu otevirat jednotlive soubory
SFleFirst = True
Do
If SFleFirst Then
SExN = Dir(SPath & SExN) ' prvni soubor v adresari
If SExN = vbNullString Then _
MsgResponse = MsgBox("Složka souboru*: '" & SPath & "' je prázdná!", _
vbOKOnly + vbInformation): Exit Do
SFleFirst = False
Else
SExN = Dir ' dalsi soubory v adresari
End If
' vsechny soubory otevreny
If SExN = vbNullString Then _
MsgResponse = MsgBox("Ve složce nejsou již další soubory pro přejmenování.", _
vbOKOnly + vbInformation): Exit Do
' otevrit soubor
On Error GoTo err
' preskoc otevreni tohoto sesitu
If Not TWbk = SExN Then
Set aWorkbook = Workbooks.Open(SPath & SExN)
OB1 = Sheets("Conditions").OptionButton1.Value
OB2 = Sheets("Conditions").OptionButton2.Value
OB3 = Sheets("Conditions").OptionButton3.Value
OB4 = Sheets("Conditions").OptionButton4.Value
OB5 = Sheets("Conditions").OptionButton5.Value
OB6 = Sheets("Conditions").OptionButton6.Value
OB7 = Sheets("Conditions").OptionButton7.Value
If OB1 = True Then
OBpopisek = Worksheets("Conditions").OptionButton1.Caption
ElseIf OB2 = True Then
OBpopisek = Worksheets("Conditions").OptionButton2.Caption
ElseIf OB3 = True Then
OBpopisek = Worksheets("Conditions").OptionButton3.Caption
ElseIf OB4 = True Then
OBpopisek = Worksheets("Conditions").TextBox1.Value
End If
If OB5 = True Then
OBpopisek2 = Worksheets("Conditions").OptionButton5.Caption
ElseIf OB6 = True Then
OBpopisek2 = Worksheets("Conditions").OptionButton6.Caption
ElseIf OB7 = True Then
OBpopisek2 = Worksheets("Conditions").OptionButton7.Caption
End If
'vytvori hyp.odkaz
aRange.Hyperlinks.Add Anchor:=aRange.Cells(aIndex, 1), Address:= _
SPath & SExN, TextToDisplay:=SExN
aRange.Cells(aIndex, 5).Value = OBpopisek
aRange.Cells(aIndex, 6).Value = aWorkbook.Worksheets("Conditions").Range("B9")
aRange.Cells(aIndex, 7).Value = aWorkbook.Worksheets("Langmuir").Range("N26")
aRange.Cells(aIndex, 8).Value = aWorkbook.Worksheets("Langmuir").Range("N33")
aRange.Cells(aIndex, 9).Value = aWorkbook.Worksheets("DR and Medek").Range("P34")
aRange.Cells(aIndex, 10).Value = aWorkbook.Worksheets("DR and Medek").Range("P27")
aRange.Cells(aIndex, 11).Value = aWorkbook.Worksheets("DR and Medek").Range("Z27")
aRange.Cells(aIndex, 12).Value = aWorkbook.Worksheets("Micropores distribution").Range("N29")
aRange.Cells(aIndex, 13).Value = aWorkbook.Worksheets("Micropores distribution").Range("N36")
aRange.Cells(aIndex, 14).Value = aWorkbook.Worksheets("Langmuir").Range("N27")
aRange.Cells(aIndex, 15).Value = aWorkbook.Worksheets("Langmuir").Range("N34")
aRange.Cells(aIndex, 16).Value = aWorkbook.Worksheets("DR and Medek").Range("P35")
aRange.Cells(aIndex, 17).Value = aWorkbook.Worksheets("DR and Medek").Range("P28")
aRange.Cells(aIndex, 18).Value = aWorkbook.Worksheets("DR and Medek").Range("Z28")
aRange.Cells(aIndex, 19).Value = aWorkbook.Worksheets("Micropores distribution").Range("N30")
aRange.Cells(aIndex, 20).Value = aWorkbook.Worksheets("Micropores distribution").Range("N37")
aRange.Cells(aIndex, 21).Value = aWorkbook.Worksheets("Langmuir").Range("N28")
aRange.Cells(aIndex, 22).Value = aWorkbook.Worksheets("Langmuir").Range("N35")
aRange.Cells(aIndex, 23).Value = aWorkbook.Worksheets("DR and Medek").Range("P36")
aRange.Cells(aIndex, 24).Value = aWorkbook.Worksheets("DR and Medek").Range("P29")
aRange.Cells(aIndex, 25).Value = aWorkbook.Worksheets("DR and Medek").Range("Z29")
aRange.Cells(aIndex, 26).Value = aWorkbook.Worksheets("Micropores distribution").Range("N31")
aRange.Cells(aIndex, 27).Value = aWorkbook.Worksheets("Micropores distribution").Range("N38")
aRange.Cells(aIndex, 28).Value = aWorkbook.Worksheets("Misc").Range("H4")
aRange.Cells(aIndex, 29).Value = aWorkbook.Worksheets("Misc").Range("H6")
err:
aIndex = aIndex + 1
On Error GoTo 0
aWorkbook.Close False
Set aWorkbook = Nothing
End If
' DoEvents
Loop
Application.ScreenUpdating = True
End Sub
Kód: Vybrat vše
Sub NactiDataZAdresare()
Dim aWorkbook As Workbook, aSheet As Object
Dim TWbk As String, SExN As String, SPath As String
Dim SFleFirst As Boolean, CntFFile As Integer, aIndex As Integer, MsgResponse As Byte
Dim OBpopisek, OBpopisek2 As Variant
'
Application.ScreenUpdating = False
' nacist parametry
Set aSheet = ActiveSheet
TWbk = ThisWorkbook.Name ' nazev tohoto souboru
SPath = ThisWorkbook.Path & "\" ' cesta k souborum
SExN = "*.xlsm" ' koncovka soubor
aIndex = 3 ' radek od ktereho se vkladaji data
' v katalogu otevirat jednotlive soubory
SFleFirst = True
Do
If SFleFirst Then
SExN = Dir(SPath & SExN) ' prvni soubor v adresari
If SExN = vbNullString Then _
MsgResponse = MsgBox("Složka souborů: '" & SPath & "' je prázdná!", _
vbOKOnly + vbInformation): Exit Do
SFleFirst = False
Else
SExN = Dir ' dalsi soubory v adresari
End If
' vsechny soubory otevreny
If SExN = vbNullString Then _
MsgResponse = MsgBox("Ve složce nejsou již další soubory k načtení.", _
vbOKOnly + vbInformation): Exit Do
' otevrit soubor
On Error GoTo err
' preskoc otevreni tohoto sesitu
If Not TWbk = SExN Then
Set aWorkbook = Workbooks.Open(SPath & SExN)
Call KopieDat(aIndex, aSheet, aWorkbook, SPath, SExN)
err:
aIndex = aIndex + 1
On Error GoTo 0
aWorkbook.Close False
Set aWorkbook = Nothing
End If
' DoEvents
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Public Sub KopieDat(aIndex As Integer, aSheet As Object, aWorkbook As Workbook, _
SPath As String, SExN As String)
Application.EnableEvents = False
If Sheets("Conditions").OptionButton1.Value = True Then
OBpopisek = Worksheets("Conditions").OptionButton1.Caption
ElseIf Sheets("Conditions").OptionButton2.Value = True Then
OBpopisek = Worksheets("Conditions").OptionButton2.Caption
ElseIf Sheets("Conditions").OptionButton3.Value = True Then
OBpopisek = Worksheets("Conditions").OptionButton3.Caption
ElseIf Sheets("Conditions").OptionButton4.Value = True Then
OBpopisek = Worksheets("Conditions").TextBox1.Value
End If
If Sheets("Conditions").OptionButton5.Value = True Then
OBpopisek2 = Worksheets("Conditions").OptionButton5.Caption
ElseIf Sheets("Conditions").OptionButton6.Value = True Then
OBpopisek2 = Worksheets("Conditions").OptionButton6.Caption
ElseIf Sheets("Conditions").OptionButton7.Value = True Then
OBpopisek2 = Worksheets("Conditions").OptionButton7.Caption
End If
'vytvori hyp.odkaz
aSheet.Hyperlinks.Add Anchor:=aSheet.Cells(aIndex, 1), _
Address:=SPath & SExN, TextToDisplay:=SExN
aSheet.Cells(aIndex, 5).Value = OBpopisek
aSheet.Cells(aIndex, 6).Value = aWorkbook.Worksheets("Conditions").Range("B9")
aSheet.Cells(aIndex, 7).Value = aWorkbook.Worksheets("Langmuir").Range("N26")
aSheet.Cells(aIndex, 8).Value = aWorkbook.Worksheets("Langmuir").Range("N33")
aSheet.Cells(aIndex, 9).Value = aWorkbook.Worksheets("DR and Medek").Range("P34")
aSheet.Cells(aIndex, 10).Value = aWorkbook.Worksheets("DR and Medek").Range("P27")
aSheet.Cells(aIndex, 11).Value = aWorkbook.Worksheets("DR and Medek").Range("Z27")
aSheet.Cells(aIndex, 12).Value = aWorkbook.Worksheets("Micropores distribution").Range("N29")
aSheet.Cells(aIndex, 13).Value = aWorkbook.Worksheets("Micropores distribution").Range("N36")
aSheet.Cells(aIndex, 14).Value = aWorkbook.Worksheets("Langmuir").Range("N27")
aSheet.Cells(aIndex, 15).Value = aWorkbook.Worksheets("Langmuir").Range("N34")
aSheet.Cells(aIndex, 16).Value = aWorkbook.Worksheets("DR and Medek").Range("P35")
aSheet.Cells(aIndex, 17).Value = aWorkbook.Worksheets("DR and Medek").Range("P28")
aSheet.Cells(aIndex, 18).Value = aWorkbook.Worksheets("DR and Medek").Range("Z28")
aSheet.Cells(aIndex, 19).Value = aWorkbook.Worksheets("Micropores distribution").Range("N30")
aSheet.Cells(aIndex, 20).Value = aWorkbook.Worksheets("Micropores distribution").Range("N37")
aSheet.Cells(aIndex, 21).Value = aWorkbook.Worksheets("Langmuir").Range("N28")
aSheet.Cells(aIndex, 22).Value = aWorkbook.Worksheets("Langmuir").Range("N35")
aSheet.Cells(aIndex, 23).Value = aWorkbook.Worksheets("DR and Medek").Range("P36")
aSheet.Cells(aIndex, 24).Value = aWorkbook.Worksheets("DR and Medek").Range("P29")
aSheet.Cells(aIndex, 25).Value = aWorkbook.Worksheets("DR and Medek").Range("Z29")
aSheet.Cells(aIndex, 26).Value = aWorkbook.Worksheets("Micropores distribution").Range("N31")
aSheet.Cells(aIndex, 27).Value = aWorkbook.Worksheets("Micropores distribution").Range("N38")
aSheet.Cells(aIndex, 28).Value = aWorkbook.Worksheets("Misc").Range("H4")
aSheet.Cells(aIndex, 29).Value = aWorkbook.Worksheets("Misc").Range("H6")
Application.EnableEvents = True
End Sub
Kód: Vybrat vše
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aSheet As Object, aWorkbook As Object
Dim SPath As String, SExN As String
Dim aIndex As Integer
Dim Response As Byte
Dim fso As Object
Dim File As String
' Proved kdyz je zmena ve sloupci, 1=A
If Target.Column = 1 Then
Set fso = CreateObject("Scripting.FileSystemObject")
SPath = ThisWorkbook.Path & "\" ' cesta k souboru
SExN = Target.Value & ".xlsm" ' nazev souboru
File = SPath & SExN ' soubor
' existuje soubor?
If (fso.FileExists(File)) Then
aIndex = Target.Row
Set aSheet = ActiveSheet
Set aWorkbook = Workbooks.Open(File)
Call KopieDat(aIndex, aSheet, aWorkbook, SPath, SExN)
aWorkbook.Close False
Else
Response = MsgBox("Soubor " & Target.Value & " nenalezen !! ", vbCritical)
End If
End If
Set fso = Nothing
Set aWorkbook = Nothing
Application.EnableEvents = True
End Sub
Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 4 hosti