Excel - makro

[cmuch]

Tak se pochlub jak si to udělal bez maker

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

[Reklama]

[Tomek001]

Aby se chybové hodnoty nemusely přiřazovat po jedné, stačí zvolit Typ chybové hodnoty --> Vlastní --> Zadat hodnotu a pak už jen označit příslušný soubor směrodatných odchylek :-)

Jinač to makro už je fakt parádní. Jen si říkám, že až budou přibývat další soubory (denně), tak je zbytečné, aby se pokaždé načítaly všechny soubory ve složce. Napadlo mě využít Tvého úplně prvního makra, které dovoluje napsáním názvu souboru (do sloupce F) automaticky načíst příslušná data. Zkoušel jsem to nějak "sešít", ale nemám ještě tolik znalostí, abych to dotáhl. Možná, že existuje elegantnější řešení.

Zde je makro, které načte všechna data z adresáře (už docela dlouhé :-) :

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



/////EDIT: Ještě další věc. Nastíním situaci.
Situace:
- Mám šablonu (xltm)
- Ve stejné složce jako šablona je umístěno devadesát datových sešitů (.dat) s různým názvem (i názvy listů se liší - ale v každém tomto sešitě je pouze jeden list). Vždy v buňce A30 je unikátní text.

Cíl:
- Potřeboval bych, aby se mi celý obsah listu z datového souboru vložil do Šablony na list PCD (ten už je vytvořen) a pak aby se soubor uložil jako xlsm pod názvem, který je ve zmíněné buňce A30. To samozřejmě potřebuji udělat se všemi devadesáti sešity.

Už je mi trapně, jak si stále vymýšlím, ale blíží se to ke zdárnému konci :-)

[cmuch]

Tak tady jsou Tři makra,
Jedno načítá všechny soubory a Třetí jen jeden soubor.

Tyto vlož do modulu. (načítá všechny soubory)

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

Toto vlož do modulu listu DATA (Stačí když pak napíšeš název souboru do sloupce A (bez koncovky) a ono ho to načte)

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


Tak to vyzkoušej. Trochu jsem to předělal, tak si je projdi.

[cmuch]

A k tomu druhému dotazu tady je soubor, tak vyzkoušej.

[Tomek001]

Jééé, děkuju za Tvůj čas :-)
Zkoušel jsem vše dát do jedné složky a pak spustit, nicméně mi to vyhodilo hlášku kterou lze vidět na obrázku a označilo mi to hodnotu ".PBar" (viz červená šipka na obrázku). Nevíš, kde by mohla být chyba?

[cmuch]

To nevím, je to na stejném principu jak to na první stránce.
To Ti šlo. Jde Ti pořád?

// Upraven soubor, nevím kde se stala chyba, ale chyběla část formuláře, přitom ten soubor, který jsem vkládal tak ten je v pořádku.