MAKRO EXCEL - Prosím o pomoc.
Napsal: 09 lis 2018 09:54
Dobrý den,
Potřeboval bych pomoct s makrem ve VBA v Excelu. Dostal jsem to jako zadanou práci a v pondělí 12.11.2018 mám toto makro předvést. Učím se VBA svépomocí celkem na rychlo a moc to nedávám. Prosím Vás tedy tímto o pomoc. Snad bude někdo tak hodný a pomůže mě s tím makrem. Odměna ho jistě nemine !!!
Zadání:
Mám několik souborů ve formátu XLS. Ukázka ve složce „data“. V přiloženém odkazu: http://leteckaposta.cz/771890990.Tyto soubory jsou vždy ve shodném formátu. Data jsou vždy na prvním listě. Ostatní listy jsou vždy prázdné.
sloupec A = časová řada (datum)
sloupec B = naměřené hodnoty
sloupec C = status
- S tím že časová řada je vždy na začátku každého souboru ve sloupci A. Nemusí být vždy stejná (nemusí tam být vždycky časová řada pro jeden měsíc) – může být delší i kratší časový interval.
- Dále se potom naměřené hodnoty a status střídavě opakují až do konce. (počet těchto řádků a sloupců s naměřenými daty a statusem můžou být různá – v závislostech na délce časové řady a počtu elektroměrů.
Makro by mělo naimportovat všechny první listy ze všech souborů, které jsou ve složce (v tomto případě 4 soubory: „1“,“2“,“3“,“4“) – může jich být i více i méně. Data jsou vždy na prvním listě v souboru, ostatní listy jsou vždy prázdné a mohou se smazat.
Tohle makro již mám(snad), viz níže, mělo by fungovat. Je tam sice natvrdo nastavená cesta odkud se soubory importují, což není ta nejlepší varianta. Pokud by tedy šlo cestu k souborům vybrat ručně a poté spustit makro bylo by to lepší a jednodušší. Ale i tato varianta se dá ale přežít, jelikož soubory stahuji a importuji pořád ze stejného adresáře.
Makro je i v odkazu, jedná se o soubor: NACTI VÍCE SEŠITŮ DO JEDNOHO.XLSM
Sub GetSheets()
Path = "C:\Users\petrm\Desktop\Nová složka (2)\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
'smazání prázdných listů
Dim SH As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each SH In Worksheets
If Application.WorksheetFunction.CountA(SH.Cells) = 0 Then SH.Delete
Next SH
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Další krok:
Poté co jsem si makrem výše naimportoval ze složky všechny listy ze sešitů do jednoho sešitu a odmazal ty prázdné listy, mě zbyli v jednom sešitě čtyři listy s daty. Dále bych nad těmito listy, které mají data, potřeboval udělat kontrolu.
Tento kód funguje jako kontrola, ale pouze zatím jen nad jedním listem. Můžete vyzkoušet, také v odkazu, který jsem poslal výše, jedná se o soubor: MAKRO KONTROLA.XLSM . Nevím jak udělat to, aby makro bralo více listů a ukládalo je např. na jeden list pod sebe.
Option Explicit
Dim tdd_dira As New Collection
Dim tdd_bez_dat As New Collection
Sub najdi_diry()
Dim pocet_radku, pocet_sloupcu
Dim oblast As Range
Dim zahlavi As Range
Dim b As Range
Dim t_start
Dim dira As Boolean
Dim dira_asi As Boolean
Dim bez_dat As Boolean
Dim i As Long
Dim tdd_celkem, tdd_spatne, tdd_bez_dat_spatne
t_start = Timer
data.Activate
output.Cells.ClearContents
Set tdd_dira = Nothing
Set tdd_bez_dat = Nothing
pocet_radku = Range("A1048576").End(xlUp).Row
pocet_sloupcu = Range("XFD1").End(xlToLeft).Column
Debug.Print "radku: " & pocet_radku, "sloupcu: " & pocet_sloupcu
Set zahlavi = [A1]
While zahlavi <> ""
If zahlavi = "Status" Then
Set oblast = Range(zahlavi.Offset(1, 0), zahlavi.Offset(pocet_radku - 1)) 'Debug.Print "oblast", oblast.Address
tdd_celkem = tdd_celkem + 1
bez_dat = True
dira = False
For Each b In oblast
'jsou vsechny hodnoty bez dat?
'If b <> "neznámá hodnota" Then bez_dat = False
If b <> "" Then bez_dat = False
If b = "" And b.Offset(1, 0) = "neznámá hodnota" Then
dira = True
Exit For
End If
If b = "" And b.Offset(-1, 0) = "neznámá hodnota" Then
dira = True
'Exit For
End If
Next
'tdd s dirou
If dira Then
tdd_dira.Add (zahlavi.Offset(0, -1))
tdd_spatne = tdd_spatne + 1
End If
'tdd bez dat
If bez_dat Then
tdd_bez_dat.Add (zahlavi.Offset(0, -1))
tdd_bez_dat_spatne = tdd_bez_dat_spatne + 1
End If
End If
Set zahlavi = zahlavi.Offset(0, 1)
Wend
'vypis tdd s dirou
output.Cells(1, 1) = "TDD od kdy do kdy: "
For i = 1 To tdd_dira.Count
output.Cells(i + 1, 1) = tdd_dira(i)
Next
'vypis tdd bez dat
output.Cells(1, 2) = "TDD bez dat celý měsíc"
For i = 1 To tdd_bez_dat.Count
output.Cells(i + 1, 2) = tdd_bez_dat(i)
Next
output.Cells(1, 3) = "tdd celkem: " & tdd_celkem
output.Cells(1, 4) = "tdd spatne: " & tdd_spatne
output.Cells(1, 5) = "tdd bez dat: " & tdd_bez_dat_spatne
output.Cells(1, 6) = "Vygenerováno: " & Now & " (" & Round(Timer - t_start, 1) & "s)"
output.Activate
Debug.Print "Konec", Round(Timer - t_start, 2) & " s", "tdd celkem: " & tdd_celkem, "dira: " & tdd_spatne, "bez dat: " & tdd_bez_dat_spatne
End Sub
Toto makro by mělo kontrolovat, že v daných datech nechybí hodnoty, takzvaně najde díru.
Mohou nastat dvě varianty, které nás budou zajímat.
1) Pokud ve sloupci nejsou žádné hodnoty, chci aby mě to ten elektroměr vypsalo „např. elektroměr 1 TDD1 (jako v makru výše - Sloupec B: TDD BEZ DAT CELÝ MĚSÍC)
2) Pokud se ve sloupci objeví status „neznámá hodnota“ většinou data po tomto statusu nepokračují – elektroměr byl demontován. To bych chtěl, aby mě také elektroměr vypsalo. Akorát ještě s časovou značkou z prvního sloupce, toho kdy tento status nastal. Abych věděl ke kterému dni a času se na elektroměr přestala posílat data. (ta funkce s tím časem v makru výše ještě není, tam je jen vyhledat tento případ a poté se vypíše elektroměr bez té časové značky) - to bych potřeboval do makra přidělat. (Momentálně je to sloupec A: TDD OD KDY DO KDY ) a vypisuje se tam jen elektroměr bez té časové značky.
__________________________________________________________________________________________________________
- Když bych to shrnul celkově, tak makro by měli vzít několik souborů (jako jsou v odkazu na začátku, ve složce "data") naimportovat je do jednoho excelovského sešitu do jednotlivých listů, nad těmito jednotlivými listy, by se měla provést kontrola naměřených dat - zda tam nejsou díry. A až se provede kontrola na jednotlivými listy, mělo by se to objevit nejlépe v jednom listě - třeba poslední v daném excelovském sešitu. Tak abych mohl dát jen CTRL C a CTRL V a odeslat emailem
kolegům dále, který tento problém budou řešit.
Je možné, že jsem na něco podstatného zapomněl. Pokusím se reagovat co možná nejrychle na vaše reakce. Nechám tu raději telefon: 724 417 290 - klidně se ozvěte. Doufám, že se tady někdo najde kdo by mě s tím pomohl to dát dohromady. Opravdu bych to potřeboval mít do pondělí hotové. Doufám, že ta část mých maker půjde snad použít. A že se to jen upraví do jednoho makra které se spustí a udělá vše za mě. Děkuji Petr M.
Potřeboval bych pomoct s makrem ve VBA v Excelu. Dostal jsem to jako zadanou práci a v pondělí 12.11.2018 mám toto makro předvést. Učím se VBA svépomocí celkem na rychlo a moc to nedávám. Prosím Vás tedy tímto o pomoc. Snad bude někdo tak hodný a pomůže mě s tím makrem. Odměna ho jistě nemine !!!
Zadání:
Mám několik souborů ve formátu XLS. Ukázka ve složce „data“. V přiloženém odkazu: http://leteckaposta.cz/771890990.Tyto soubory jsou vždy ve shodném formátu. Data jsou vždy na prvním listě. Ostatní listy jsou vždy prázdné.
sloupec A = časová řada (datum)
sloupec B = naměřené hodnoty
sloupec C = status
- S tím že časová řada je vždy na začátku každého souboru ve sloupci A. Nemusí být vždy stejná (nemusí tam být vždycky časová řada pro jeden měsíc) – může být delší i kratší časový interval.
- Dále se potom naměřené hodnoty a status střídavě opakují až do konce. (počet těchto řádků a sloupců s naměřenými daty a statusem můžou být různá – v závislostech na délce časové řady a počtu elektroměrů.
Makro by mělo naimportovat všechny první listy ze všech souborů, které jsou ve složce (v tomto případě 4 soubory: „1“,“2“,“3“,“4“) – může jich být i více i méně. Data jsou vždy na prvním listě v souboru, ostatní listy jsou vždy prázdné a mohou se smazat.
Tohle makro již mám(snad), viz níže, mělo by fungovat. Je tam sice natvrdo nastavená cesta odkud se soubory importují, což není ta nejlepší varianta. Pokud by tedy šlo cestu k souborům vybrat ručně a poté spustit makro bylo by to lepší a jednodušší. Ale i tato varianta se dá ale přežít, jelikož soubory stahuji a importuji pořád ze stejného adresáře.
Makro je i v odkazu, jedná se o soubor: NACTI VÍCE SEŠITŮ DO JEDNOHO.XLSM
Sub GetSheets()
Path = "C:\Users\petrm\Desktop\Nová složka (2)\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
'smazání prázdných listů
Dim SH As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each SH In Worksheets
If Application.WorksheetFunction.CountA(SH.Cells) = 0 Then SH.Delete
Next SH
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Další krok:
Poté co jsem si makrem výše naimportoval ze složky všechny listy ze sešitů do jednoho sešitu a odmazal ty prázdné listy, mě zbyli v jednom sešitě čtyři listy s daty. Dále bych nad těmito listy, které mají data, potřeboval udělat kontrolu.
Tento kód funguje jako kontrola, ale pouze zatím jen nad jedním listem. Můžete vyzkoušet, také v odkazu, který jsem poslal výše, jedná se o soubor: MAKRO KONTROLA.XLSM . Nevím jak udělat to, aby makro bralo více listů a ukládalo je např. na jeden list pod sebe.
Option Explicit
Dim tdd_dira As New Collection
Dim tdd_bez_dat As New Collection
Sub najdi_diry()
Dim pocet_radku, pocet_sloupcu
Dim oblast As Range
Dim zahlavi As Range
Dim b As Range
Dim t_start
Dim dira As Boolean
Dim dira_asi As Boolean
Dim bez_dat As Boolean
Dim i As Long
Dim tdd_celkem, tdd_spatne, tdd_bez_dat_spatne
t_start = Timer
data.Activate
output.Cells.ClearContents
Set tdd_dira = Nothing
Set tdd_bez_dat = Nothing
pocet_radku = Range("A1048576").End(xlUp).Row
pocet_sloupcu = Range("XFD1").End(xlToLeft).Column
Debug.Print "radku: " & pocet_radku, "sloupcu: " & pocet_sloupcu
Set zahlavi = [A1]
While zahlavi <> ""
If zahlavi = "Status" Then
Set oblast = Range(zahlavi.Offset(1, 0), zahlavi.Offset(pocet_radku - 1)) 'Debug.Print "oblast", oblast.Address
tdd_celkem = tdd_celkem + 1
bez_dat = True
dira = False
For Each b In oblast
'jsou vsechny hodnoty bez dat?
'If b <> "neznámá hodnota" Then bez_dat = False
If b <> "" Then bez_dat = False
If b = "" And b.Offset(1, 0) = "neznámá hodnota" Then
dira = True
Exit For
End If
If b = "" And b.Offset(-1, 0) = "neznámá hodnota" Then
dira = True
'Exit For
End If
Next
'tdd s dirou
If dira Then
tdd_dira.Add (zahlavi.Offset(0, -1))
tdd_spatne = tdd_spatne + 1
End If
'tdd bez dat
If bez_dat Then
tdd_bez_dat.Add (zahlavi.Offset(0, -1))
tdd_bez_dat_spatne = tdd_bez_dat_spatne + 1
End If
End If
Set zahlavi = zahlavi.Offset(0, 1)
Wend
'vypis tdd s dirou
output.Cells(1, 1) = "TDD od kdy do kdy: "
For i = 1 To tdd_dira.Count
output.Cells(i + 1, 1) = tdd_dira(i)
Next
'vypis tdd bez dat
output.Cells(1, 2) = "TDD bez dat celý měsíc"
For i = 1 To tdd_bez_dat.Count
output.Cells(i + 1, 2) = tdd_bez_dat(i)
Next
output.Cells(1, 3) = "tdd celkem: " & tdd_celkem
output.Cells(1, 4) = "tdd spatne: " & tdd_spatne
output.Cells(1, 5) = "tdd bez dat: " & tdd_bez_dat_spatne
output.Cells(1, 6) = "Vygenerováno: " & Now & " (" & Round(Timer - t_start, 1) & "s)"
output.Activate
Debug.Print "Konec", Round(Timer - t_start, 2) & " s", "tdd celkem: " & tdd_celkem, "dira: " & tdd_spatne, "bez dat: " & tdd_bez_dat_spatne
End Sub
Toto makro by mělo kontrolovat, že v daných datech nechybí hodnoty, takzvaně najde díru.
Mohou nastat dvě varianty, které nás budou zajímat.
1) Pokud ve sloupci nejsou žádné hodnoty, chci aby mě to ten elektroměr vypsalo „např. elektroměr 1 TDD1 (jako v makru výše - Sloupec B: TDD BEZ DAT CELÝ MĚSÍC)
2) Pokud se ve sloupci objeví status „neznámá hodnota“ většinou data po tomto statusu nepokračují – elektroměr byl demontován. To bych chtěl, aby mě také elektroměr vypsalo. Akorát ještě s časovou značkou z prvního sloupce, toho kdy tento status nastal. Abych věděl ke kterému dni a času se na elektroměr přestala posílat data. (ta funkce s tím časem v makru výše ještě není, tam je jen vyhledat tento případ a poté se vypíše elektroměr bez té časové značky) - to bych potřeboval do makra přidělat. (Momentálně je to sloupec A: TDD OD KDY DO KDY ) a vypisuje se tam jen elektroměr bez té časové značky.
__________________________________________________________________________________________________________
- Když bych to shrnul celkově, tak makro by měli vzít několik souborů (jako jsou v odkazu na začátku, ve složce "data") naimportovat je do jednoho excelovského sešitu do jednotlivých listů, nad těmito jednotlivými listy, by se měla provést kontrola naměřených dat - zda tam nejsou díry. A až se provede kontrola na jednotlivými listy, mělo by se to objevit nejlépe v jednom listě - třeba poslední v daném excelovském sešitu. Tak abych mohl dát jen CTRL C a CTRL V a odeslat emailem
kolegům dále, který tento problém budou řešit.
Je možné, že jsem na něco podstatného zapomněl. Pokusím se reagovat co možná nejrychle na vaše reakce. Nechám tu raději telefon: 724 417 290 - klidně se ozvěte. Doufám, že se tady někdo najde kdo by mě s tím pomohl to dát dohromady. Opravdu bych to potřeboval mít do pondělí hotové. Doufám, že ta část mých maker půjde snad použít. A že se to jen upraví do jednoho makra které se spustí a udělá vše za mě. Děkuji Petr M.