Excel - makro

[cmuch]

Ad1)
Projdi makro v té příloze na to přejmenování souborů, tam to je.

Ad2)

Ale jak postupovat při importování hodnoty z formuláře?

Do toho formůláře se načítají data odkud?
Nebo nevím jestli chápu tento bod dobře.

[Reklama]

[Tomek001]

1) Asi jsem vážně lama na tyhle věci :(

Kód: Vybrat vše

aFilename = "RUN_" & aIndex & ".xlsm"

jsem předělal na:

Kód: Vybrat vše

aFilename = ThisWorkbook.Path & "\" & Target.Value & ".xlsm"

a nefunguje to - vyskočí hláška Object required.

2) Ten formulář data nenačítá, jsou tam prostě vypsány jakési tři možnosti - vždy jedna z nich je vybrána - viz přiložený obrázek. A tu vybranou hodnotu právě potřebuju importovat.

EDIT - teď jsem si všiml, že při tvoření mustru jsem omylem tyto ovládací prvky vložil jako Ovládací prvky formuláře a ne jako Ovládací prvky ActiveX :( Tudíž se to všechno zase komplikuje. Spravit by to nebyl problém, kdybych neměl tolik desítek souborů. Napadlo mě ale, že každému z těch tří tlačítek (pojmenovaných jako "přepínač 119" -"přepínač -121" je vedle v buňce přiřazen text, který potřebuju importovat. Tudíž by to mohlo fingovat tak, že pokud bude zaškrtnutý přepínač 119, tak se naimportuje hodnota 0.06 - 0.015 mm. Pokud bude zaškrtnutý přepínač 120, tak se naimp. hodnota < 0.06 mm, atd.
Lze to nějak tak vymyslet, nebo už si moc vymýšlím? Omlouvám se za zmatené informace.

[cmuch]

Ad2)
Pokud to jsou prvky formuláře tak přes pravé tl. na prvku vybrat formát ovádacího prvku --- ovládací prvek -- a nastavit propojení s buňkou.
A na tu se pak dotazovat v makru jestli je 1 nebo 0.

Pokud by to byli AktiveX tak by se to dalo třeba takto v makru dotázat OB1 = OptionButton1 jestli je False nebo True

Ad1)
vyzkoušej, já nemám načem.

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
      '
      Application.ScreenUpdating = False
      ' nacist parametry
      Set aRange = Range("G3: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 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 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)
       
          aRange.Cells(aIndex, 1).Value = aWorkbook.Worksheets("Conditions").Range("B9")
          aRange.Cells(aIndex, 2).Value = aWorkbook.Worksheets("Langmuir").Range("N26")
          aRange.Cells(aIndex, 3).Value = aWorkbook.Worksheets("Langmuir").Range("N33")
          aRange.Cells(aIndex, 4).Value = aWorkbook.Worksheets("DR and Medek").Range("P34")
          aRange.Cells(aIndex, 5).Value = aWorkbook.Worksheets("DR and Medek").Range("P27")
          aRange.Cells(aIndex, 6).Value = aWorkbook.Worksheets("DR and Medek").Range("Z27")
          aRange.Cells(aIndex, 7).Value = aWorkbook.Worksheets("Micropores distribution").Range("N29")
          aRange.Cells(aIndex, 8).Value = aWorkbook.Worksheets("Micropores distribution").Range("N36")
           
          aRange.Cells(aIndex, 9).Value = aWorkbook.Worksheets("Langmuir").Range("N27")
          aRange.Cells(aIndex, 10).Value = aWorkbook.Worksheets("Langmuir").Range("N34")
          aRange.Cells(aIndex, 11).Value = aWorkbook.Worksheets("DR and Medek").Range("P35")
          aRange.Cells(aIndex, 12).Value = aWorkbook.Worksheets("DR and Medek").Range("P28")
          aRange.Cells(aIndex, 13).Value = aWorkbook.Worksheets("DR and Medek").Range("Z28")
          aRange.Cells(aIndex, 14).Value = aWorkbook.Worksheets("Micropores distribution").Range("N30")
          aRange.Cells(aIndex, 15).Value = aWorkbook.Worksheets("Micropores distribution").Range("N37")
           
          aRange.Cells(aIndex, 16).Value = aWorkbook.Worksheets("Langmuir").Range("N28")
          aRange.Cells(aIndex, 17).Value = aWorkbook.Worksheets("Langmuir").Range("N35")
          aRange.Cells(aIndex, 18).Value = aWorkbook.Worksheets("DR and Medek").Range("P36")
          aRange.Cells(aIndex, 19).Value = aWorkbook.Worksheets("DR and Medek").Range("P29")
          aRange.Cells(aIndex, 20).Value = aWorkbook.Worksheets("DR and Medek").Range("Z29")
          aRange.Cells(aIndex, 21).Value = aWorkbook.Worksheets("Micropores distribution").Range("N31")
          aRange.Cells(aIndex, 22).Value = aWorkbook.Worksheets("Micropores distribution").Range("N38")
          aRange.Cells(aIndex, 23).Value = aWorkbook.Worksheets("Conditions").OptionButton1
err:
          aIndex = aIndex + 1

          On Error GoTo 0
          aWorkbook.Close False
       
          Set aWorkbook = Nothing
        End If
        '  DoEvents
      Loop
     
      Application.ScreenUpdating = True
End Sub


// Upraveno - makro nebude otevírat sešit v kterém je toto makro

[Tomek001]

Píše mi to: Složka slouboru* C:... je prázdná. Přitom tam xlms soubory mám. Nebude pro Tebe jednodušší, když Ti ten soubor raději pošlu?

[cmuch]

To je divné, máš správnou koncovku?

Kód: Vybrat vše

SExN = "*.xlsm"                  ' koncovka soubor

[Tomek001]

Nevím čím to je, ale z flešky to nejede....po překopírování na pevný disk a odstranění prázdné složky není celkem problém. Akorát to na konci chce otevřít "sebe samo" - ale to nevadí :-)Takže tohle považuj za vyřešeno.

Pokud se vrátím k těm tlačítkům - předělal jsem je do ActiveX. Nicméně, toto:

Kód: Vybrat vše

aRange.Cells(aIndex, 23).Value = aWorkbook.Worksheets("Conditions").OptionButton1.Value = True

nefunguje jak má...po spuštění makra se mi tam objeví pouze "PRAVDA" a né popisek toho buttonu

[cmuch]

Akorát to na konci chce otevřít "sebe samo" - ale to nevadí :-)

Upravil jsem v předchozí příloze

Pokud se vrátím k těm tlačítkům

Pokud bude to makro na listu s těmi prvky tak můžeš smazat Sheets("Conditions").
Takto je pod sebe vypiš a mohlo by to splňovat co potřebuješ

Kód: Vybrat vše

OB5 = Sheets("Conditions").OptionButton5.Value
OB6 = Sheets("Conditions").OptionButton6.Value
  If OB5 = True Then
    OB5popisek = Worksheets("Conditions").OptionButton5.Caption
   ElseIf OB6 = True Then
    OB5popisek = Worksheets("Conditions").OptionButton6.Caption
  End If

[Tomek001]

Takto je pod sebe vypiš a mohlo by to splňovat co potřebuješ

Kód: Vybrat vše

    OB5 = Sheets("Conditions").OptionButton5.Value
    OB6 = Sheets("Conditions").OptionButton6.Value
      If OB5 = True Then
        OB5popisek = Worksheets("Conditions").OptionButton5.Caption
       ElseIf OB6 = True Then
        OB5popisek = Worksheets("Conditions").OptionButton6.Caption
      End If

Chápu-li to dobře - pokud mám v jednom rámečku OptionButton1-4 (a u 4 i textbox, do kterého uživatel vypíše údaje "jiné", tak to bude vypadat takto?

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
          '
          Application.ScreenUpdating = False
          ' nacist parametry
          Set aRange = Range("G3: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 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 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
                OB6 = Sheets("Conditions").OptionButton6.Value
                  If OB1 = True Then
                    OB5popisek = Worksheets("Conditions").OptionButton1.Caption
                   ElseIf OB6 = True Then
                    OB5popisek = Worksheets("Conditions").OptionButton6.Caption
                  End If
           
              aRange.Cells(aIndex, 1).Value = aWorkbook.Worksheets("Conditions").Range("B9")
              aRange.Cells(aIndex, 2).Value = aWorkbook.Worksheets("Langmuir").Range("N26")
              aRange.Cells(aIndex, 3).Value = aWorkbook.Worksheets("Langmuir").Range("N33")
              aRange.Cells(aIndex, 4).Value = aWorkbook.Worksheets("DR and Medek").Range("P34")
              aRange.Cells(aIndex, 5).Value = aWorkbook.Worksheets("DR and Medek").Range("P27")
              aRange.Cells(aIndex, 6).Value = aWorkbook.Worksheets("DR and Medek").Range("Z27")
              aRange.Cells(aIndex, 7).Value = aWorkbook.Worksheets("Micropores distribution").Range("N29")
              aRange.Cells(aIndex, 8).Value = aWorkbook.Worksheets("Micropores distribution").Range("N36")
               
              aRange.Cells(aIndex, 9).Value = aWorkbook.Worksheets("Langmuir").Range("N27")
              aRange.Cells(aIndex, 10).Value = aWorkbook.Worksheets("Langmuir").Range("N34")
              aRange.Cells(aIndex, 11).Value = aWorkbook.Worksheets("DR and Medek").Range("P35")
              aRange.Cells(aIndex, 12).Value = aWorkbook.Worksheets("DR and Medek").Range("P28")
              aRange.Cells(aIndex, 13).Value = aWorkbook.Worksheets("DR and Medek").Range("Z28")
              aRange.Cells(aIndex, 14).Value = aWorkbook.Worksheets("Micropores distribution").Range("N30")
              aRange.Cells(aIndex, 15).Value = aWorkbook.Worksheets("Micropores distribution").Range("N37")
               
              aRange.Cells(aIndex, 16).Value = aWorkbook.Worksheets("Langmuir").Range("N28")
              aRange.Cells(aIndex, 17).Value = aWorkbook.Worksheets("Langmuir").Range("N35")
              aRange.Cells(aIndex, 18).Value = aWorkbook.Worksheets("DR and Medek").Range("P36")
              aRange.Cells(aIndex, 19).Value = aWorkbook.Worksheets("DR and Medek").Range("P29")
              aRange.Cells(aIndex, 20).Value = aWorkbook.Worksheets("DR and Medek").Range("Z29")
              aRange.Cells(aIndex, 21).Value = aWorkbook.Worksheets("Micropores distribution").Range("N31")
              aRange.Cells(aIndex, 22).Value = aWorkbook.Worksheets("Micropores distribution").Range("N38")
              aRange.Cells(aIndex, 23).Value = aWorkbook.Worksheets("Conditions").OptionButton1
               
err:
              aIndex = aIndex + 1

              On Error GoTo 0
              aWorkbook.Close False
           
              Set aWorkbook = Nothing
            End If
            '  DoEvents
          Loop
         
          Application.ScreenUpdating = True
    End Sub




Mě se to po importu totiž vypisuje jako "PRAVDA"

[cmuch]

Skoro tak

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("G3: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 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 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
       
          aRange.Cells(aIndex, 1).Value = aWorkbook.Worksheets("Conditions").Range("B9")
          aRange.Cells(aIndex, 2).Value = aWorkbook.Worksheets("Langmuir").Range("N26")
          aRange.Cells(aIndex, 3).Value = aWorkbook.Worksheets("Langmuir").Range("N33")
          aRange.Cells(aIndex, 4).Value = aWorkbook.Worksheets("DR and Medek").Range("P34")
          aRange.Cells(aIndex, 5).Value = aWorkbook.Worksheets("DR and Medek").Range("P27")
          aRange.Cells(aIndex, 6).Value = aWorkbook.Worksheets("DR and Medek").Range("Z27")
          aRange.Cells(aIndex, 7).Value = aWorkbook.Worksheets("Micropores distribution").Range("N29")
          aRange.Cells(aIndex, 8).Value = aWorkbook.Worksheets("Micropores distribution").Range("N36")
           
          aRange.Cells(aIndex, 9).Value = aWorkbook.Worksheets("Langmuir").Range("N27")
          aRange.Cells(aIndex, 10).Value = aWorkbook.Worksheets("Langmuir").Range("N34")
          aRange.Cells(aIndex, 11).Value = aWorkbook.Worksheets("DR and Medek").Range("P35")
          aRange.Cells(aIndex, 12).Value = aWorkbook.Worksheets("DR and Medek").Range("P28")
          aRange.Cells(aIndex, 13).Value = aWorkbook.Worksheets("DR and Medek").Range("Z28")
          aRange.Cells(aIndex, 14).Value = aWorkbook.Worksheets("Micropores distribution").Range("N30")
          aRange.Cells(aIndex, 15).Value = aWorkbook.Worksheets("Micropores distribution").Range("N37")
           
          aRange.Cells(aIndex, 16).Value = aWorkbook.Worksheets("Langmuir").Range("N28")
          aRange.Cells(aIndex, 17).Value = aWorkbook.Worksheets("Langmuir").Range("N35")
          aRange.Cells(aIndex, 18).Value = aWorkbook.Worksheets("DR and Medek").Range("P36")
          aRange.Cells(aIndex, 19).Value = aWorkbook.Worksheets("DR and Medek").Range("P29")
          aRange.Cells(aIndex, 20).Value = aWorkbook.Worksheets("DR and Medek").Range("Z29")
          aRange.Cells(aIndex, 21).Value = aWorkbook.Worksheets("Micropores distribution").Range("N31")
          aRange.Cells(aIndex, 22).Value = aWorkbook.Worksheets("Micropores distribution").Range("N38")
          aRange.Cells(aIndex, 23).Value = OBpopisek
          aRange.Cells(aIndex, 24).Value = OBpopisek2
err:
          aIndex = aIndex + 1

          On Error GoTo 0
          aWorkbook.Close False
       
          Set aWorkbook = Nothing
        End If
        '  DoEvents
      Loop
     
      Application.ScreenUpdating = True
End Sub

Rozdíl hledej u aRange.Cells(aIndex, 23).Value + jsem poupravil i začátek.

[Tomek001]

To je úplně úžasné, ono to funguje jak má, moc děkuju! :-)

Teď když mám naimportovaná data v jednom souboru, lze pomocí makra vytvořit bodový nebo sloupcový graf (pro cca 100 hodnot)? Problém je, že každá hodnota = jedna řada. A každé jedné hodnotě musím přiřadit jednu chybovou úsečku. Tzn. např. hodnota x=sl.A, hodnota y=sl. B, hodnota chybové úsečky =sl. C. Dělat tolik hodnot ručně by bylo nesmyslné, dají se tedy grafy nějak vytvořit automaticky?

[cmuch]

Zkus si pohrát se záznamníkem maker.

[Tomek001]

Už to mám, dokonce jsem makro ani použít nemusel :-)

Jen by mě zajímalo ještě, zdali by šlo výše uvedený kod vylepšit o to, abych mohl přímo z excelovského sešitu otevírat (pomocí hypertextového odkazu) jednotlivé sešity se vzorky. Vím, jak to udělat bez maker, ale je to neuvěřitelně zdlouhavé. Vše se nachází v jedné složce.
Nejlepší by bylo, kdyby se vytvořil další sloupec, třeba pomocí aRange.Cells(aIndex, 25).Value = a název v každém řádku by korespondoval s názvem souboru (vše .xlsm). Tzn, když mám vzorek (sešit) ABC.xlsm, tak aby se mi vytvořil kliknutelný odkaz ABC

Už si moc vymýšlím, co? :)