Na prvním listě je filtr zapnut i na sloupci ID, na druhém listě nikoliv.
OB napsal/a:
Ještě prosím o jednu pomoc. Když se stáhnou všechny data ze všech souborů z adresáře DATA do souboru Souhrn02_funguje, ale v listu DataSouboru ve sloupci G jsou příliš "nafouklá" čísla a to vždy o "tři nuly" takže pak umazávám poslední 000, zřejmě je to chyba při převodu z jednotlivých souborů (hodnoty jsou čísla) z adresáře DATA.
Díky.
Aha, takže Tvůj problém je, že neumíš vyhodnotit podmínku. Do proměnné Volba1 si můžeš narvat co je libo, nebo ji klidně nechat prázdnou (Volba1 = ""). Tvůj zápis Volba1 ="<>" (proměnná tedy obsahuje textový řetězec <>.
If ListZdroj1.Cells(Radek1, 6).Value = Volba1 Then
Tedy:
If ListZdroj1.Cells(Radek1, 6).Value = <> Then
Což je samozřejmě blbost.
Tedy pokud buňka v šestém sloupci neobsahuje hodnotu <>
Vyhodnocovací operátor je přeci v tomto případě =, nikoliv <>.
PS:
Pokud hodláš vyhodnocovat 39 různých hodnot v proměnné, místo IF THEN ELSE, používej SELECT CASE.
Porovnávací operátor <> (Nerovná se) ve VBA samozřejmě funguje.
Problém bude v deklaraci nebo převodu datových typů - (je to 39 různých hodnot, text i číslo)
Je to číslo opravdu číslo? Nebo je to text?
@Veny Ti to už jednou psal, vzorec musí být MATICOVÝ (poznáš to podle toho, že je uzavřen do složených závorek).
Public Sub radky2()
Application.ScreenUpdating = False 'zakázat vykreslování v průběhu makra - zvýší rychlost
Dim radek As Long
radek = 1
Do While Cells(radek, 1) <> "" 'maximum řádků na listu, ale lze nastavit vlastní a nižší šíslo - makro pak bude rychlejší protože bude ověřovat jen třeba 2000 řádků
Rows(radek + 1).Resize(2).EntireRow.Insert ' Cells(radek + 1, 1).EntireRow.Insert
radek = radek + 3
Loop
Application.ScreenUpdating = True 'povolit vykreslování
End Sub
Private Sub CommandButton1_Click()
Dim Radek As Long
With Worksheets("List2")
Radek = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(Radek, 1).Value = Worksheets("List1").Cells(1, 1).Value
End With
End Sub
Tohle by mělo pomoct:
Select Case True
Case Item Like "*A*": X_X = 10
Case Item Like "*B*": X_X = 11
Case Else: X_X = 12
End Select
Např:
Sub prepis_komentar()
Dim Oblast As Range
Dim Bunka As Range
Set Oblast = Range("A1:A20")
For Each Bunka In Oblast
If Not Bunka.Comment Is Nothing Then
Bunka.Comment.Text Text:=Replace(Bunka.Comment.Text, "f", "7")
End If
Next Bunka
Set Oblast = Nothing
End Sub
Upraveno
Ten kód co si sem vložil běží 10 minut?
A když vypneš překreslování obrazovky a automatický přepočet listu? (viz soubor)
Jednoduše.
Řešení maticovým vzorcem. Jeho ukončení se provede trojkombinací CTRL+SHIFT+ENTER
Sakra ještě ten soubor.
Proboha odkud se berou ty soubory *.xls?
Při otevření hlásí chybu viz obr.
Předělal sem kód, protože vzorce vracely chybu #odkaz
a upravil rozsahy buněk. Né u všech souborů xls začínají data na řádku 31 !
Je to sice pomalé, ale vypadá to, že i snad funkční.
Otestuj.
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.