EXCEL Makro

[lu2cz]

Dobry den,

najde se nejaky dobrak, ktery mi pomuze navrhnout makro? Potrebuju makro, ktere otevre soubor umisteny v adresari, ve kterem je puvodni soubor obsahujici makro a z tohoto souboru prekopirovat radky splnujici urcitou podminku (datum uvedeny v jednom sloupci bude v rozsahu zadanem nekde v puvodnim souboru) do listu puvodniho souboru. Diky moc.

Janek

[Reklama]

[Branscombe]

Ahoj, to by neměl by problém. Přilož demo soubory se zadáním a požadovaným výsledkem ...

[lu2cz]

Super, rad se priucim. S makry teprve zacinam, tak je to pro me celkem orisek :). Prikladam demo soubory. Makro by melko byt soucasti souboru "Results" spustitelne napr. pomoci tlacitka v listu "Filtr" po dosazeni pozadovaneho rozpeti v tom samem listu. Moje predstava je:

1) smazat obsah Listu "SAL+EXC" v souboru "Results" pro pripad, ze obsahuje data z minula
2) otevrit soubor "SAL+EXC" a kazdy radek splnujici podminku, ze datum ve sloupci F je v rozmezi zadanem v listu "Filtr", se prekopiruje do listu "SAL+EXC" souboru "Results" pocinaje radkem 2 (aby hlavicka zustala zachovana)
3) soubor "SAL+EXC" se zavre. (zrejme neni ani potreba, aby ho excel otviral :))
3) obdobne pro soubor "REF" a list "REF" v souboru "Results".

Za jakoukoliv pomoc budu vdecny. Diky

Pokus.zip

(168.4 KiB) Staženo 16 x

[Branscombe]

Ahoj, možná jsem to nenapsal moc pěkně co se programování týče, ale zkus to, mělo by to fungovat.
Dle záhlaví jsem usoudil že kopírovaná data budou ve sloupcích A:M
V případě potřeby uprav sám nebo dej vědět. Kdyby cokoliv nebylo jasné, tak se ozvi ...

Do standartního modulu procedury vlož:

Kód: Vybrat vše

Sub Potvrd()

Dim Adresa As String, condition1 As Range, condition2 As Range, Cll As Range, Cll2 As Range, Oblast1 As Range, posledni_zaznam As Long

Adresa = ThisWorkbook.Path
Set condition1 = Worksheets("Filter").Range("B3")
Set condition2 = Worksheets("Filter").Range("C3")

Worksheets("SAL+EXC").Range("A2:M65536").ClearContents
Worksheets("REF").Range("A2:M65536").ClearContents

Workbooks.Open (Adresa & "\SAL+EXC.xls")

Set Oblast1 = Workbooks("SAL+EXC.xls").Worksheets("SAL+EXC").Range("F2:F" & Worksheets("SAL+EXC").Cells(Worksheets("SAL+EXC").Rows.Count, 6).End(xlUp).Row)

For Each Cll In Oblast1

Cll.Value = DateValue(Cll)

If Cll > condition1 And Cll < condition2 Then

    posledni_zaznam = Workbooks("Results.xls").Worksheets("SAL+EXC").Cells(Rows.Count, "F").End(xlUp).Row + 1
    Set Cll2 = Workbooks("Results.xls").Worksheets("SAL+EXC").Range("A" & posledni_zaznam & "")
   
    Cll2.Offset(0, 0) = Cll.Offset(0, -5)
    Cll2.Offset(0, 1) = Cll.Offset(0, -4)
    Cll2.Offset(0, 2) = Cll.Offset(0, -3)
    Cll2.Offset(0, 3) = Cll.Offset(0, -2)
    Cll2.Offset(0, 4) = Cll.Offset(0, -1)
    Cll2.Offset(0, 5) = Cll.Offset(0, 0).Value
    Cll2.Offset(0, 6) = Cll.Offset(0, 1)
    Cll2.Offset(0, 7) = Cll.Offset(0, 2)
    Cll2.Offset(0, 8) = Cll.Offset(0, 3)
    Cll2.Offset(0, 9) = Cll.Offset(0, 4)
    Cll2.Offset(0, 10) = Cll.Offset(0, 5)
    Cll2.Offset(0, 11) = Cll.Offset(0, 6)
    Cll2.Offset(0, 12) = Cll.Offset(0, 7)
    Cll2.Offset(0, 13) = Cll.Offset(0, 8)

End If

Next

Workbooks("SAL+EXC.xls").Close False

Workbooks.Open (Adresa & "\REF.xls")

Set Oblast1 = Workbooks("REF.xls").Worksheets("REF").Range("F2:F" & Worksheets("REF").Cells(Worksheets("REF").Rows.Count, 6).End(xlUp).Row)

For Each Cll In Oblast1

Cll.Value = DateValue(Cll)

If Cll > condition1 And Cll < condition2 Then

    posledni_zaznam = Workbooks("Results.xls").Worksheets("REF").Cells(Rows.Count, "F").End(xlUp).Row + 1
    Set Cll2 = Workbooks("Results.xls").Worksheets("REF").Range("A" & posledni_zaznam & "")
   
    Cll2.Offset(0, 0) = Cll.Offset(0, -5)
    Cll2.Offset(0, 1) = Cll.Offset(0, -4)
    Cll2.Offset(0, 2) = Cll.Offset(0, -3)
    Cll2.Offset(0, 3) = Cll.Offset(0, -2)
    Cll2.Offset(0, 4) = Cll.Offset(0, -1)
    Cll2.Offset(0, 5) = Cll.Offset(0, 0).Value
    Cll2.Offset(0, 6) = Cll.Offset(0, 1)
    Cll2.Offset(0, 7) = Cll.Offset(0, 2)
    Cll2.Offset(0, 8) = Cll.Offset(0, 3)
    Cll2.Offset(0, 9) = Cll.Offset(0, 4)
    Cll2.Offset(0, 10) = Cll.Offset(0, 5)
    Cll2.Offset(0, 11) = Cll.Offset(0, 6)
    Cll2.Offset(0, 12) = Cll.Offset(0, 7)
    Cll2.Offset(0, 13) = Cll.Offset(0, 8)

End If

Next

Workbooks("REF.xls").Close False

End Sub



[lu2cz]

Makro se zastavi na tomto radku: Cll.Value = DateValue(Cll). Napada te neco? Diky za pomoc.

Janek

[Branscombe]

Bohužel, problém bude ve verzi Excelu ... Bohužel nemohu odzkoušet na Excel 2003 ...

[lu2cz]

Problem je ve formatu datumu ve sloupci "F" pro funkci "=DateValue()". Mate nekdo nejaky napad jak kontrolovat, zda-li datum uvedeny jako text ve formatu DD.MM.YYYY, vyhovuje zadanemu rozsahu?

Napad :)

Mohli bychom prevest text do sloupcu pomoci funkce "TextToColumns", tim ziskat z textoveho formatu "den", "mesic" a "rok", a zpetne pouzitim funkce "DATE" ziskat datum ve formatu DATUM. Tento by jiz melo jit porovnavat s datem zadani (samozrejme zadanem ve stejnem formatu). Dokazal bys makro takto upravit?