Příspěvky uživatele

Zdravim,

zkus nasledujici:
Sub test()
Dim ws As Worksheet, a, b, i As Long, m As Long, lr As Long, rng As Range
Set ws = ActiveSheet
On Error GoTo ER
Application.ScreenUpdating = False
With ws
a = .Range("F3:I3")
Set rng = .Cells(4, 6)
lr = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 1 To UBound(a, 2)
.Range("A3:B3").AutoFilter field:=1, Criteria1:=a(1, i)
b = .Range("B4:B" & lr).SpecialCells(12).Cells.Value
m = UBound(b, 1)
Set rng = rng.Resize(m, 1)
.ShowAllData
rng = b
Set rng = rng.Resize(1, 1).Offset(0, 1)
Next i
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
Exit Sub
ER:
Application.ScreenUpdating = True
MsgBox ("Chyba: " & Err.Number & " - " & Err.Description), vbCritical, "Konec"
End Sub

Kdyz budu vedet, co je vasim zamerem, task se pokusim. Nahrajte ukazkovy sesit, zmente citliva data, popiste, co je treba provest...

Zdravim,
misto vaseho
If rng.Cells(i) = IsText Then
by to melo byt
If Application.WorksheetFunction.IsText(rng.Cells(i)) Then

Taky mi pripada trochu divny ten cyklus.. zda se mi rng.Rows.Count bude vzdy 1... tedy z te oblasti bude zkoumat pouze obsah prvni bunky ale druhe ne...

syd

Je to mozne, ovsem je treba mit aspon trochu znalosti vba
Napr.za pomoci kodu z teto stranky
http://www.rondebruin.nl/win/s9/win002.htm

Po jiste uprave lze napr. otevrit postupne vsechny soubory *.xls z jedne slozky, vlozit do souboru modul .bas, tento kod z z nej spustit, a nakonec ulozit jeko *.xlsm do jine slozky.

syd

Treba pomuze toto.
Za pouziti mezery tento kod vlozeny do modulu listu1 premeni vse napsane do sloupce A napr. 02 09 45 -> 02:09:45.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column = 1 Then
Application.EnableEvents = False
Target = Replace(Target.Value, " ", ":")
Target.NumberFormat = "hh:mm:ss"
Application.EnableEvents = True
End If
End Sub

Tak napr. udelat spise pomoci overeni dat - seznam (prijde mi to jednodussi)a vzorce hvyhledat. Listy soupiska a tymy by slo sloucit do jedne tabulky.
syd

No me to moc nemysli, tak se radsi zeptam

Vyzkousej, zda to ma zadany vysledek

Dobry den,

mohl bych se na to kouknout. Studoval jsem soubor, je tedy opravdu zajimavy, takhle resit makra jsem jeste nevidel.
Mam ale problem, ze nevim, jak ma vypadat spravne vysledek.
Ze dvou radku se v liste duplicity stanou radky tri, ze tri ctyri... s jednim dva... to je vporadku?
Chapu tez spravne, ze unikatni jsou id 1, 3 a ostatni tedy dvou a vice radkove id jsou duplicitni?

syd

Zdravim,

zde verze bez formulare. Vse co je v oblasti A2:F az posledni radek klasifikacniho kodu (zde by to urcite chtelo osetrit, aby clovek nepsal do bunek kraviny) na listu Zadani je filtrovano v ostanich dvou listech a vysledek vlozen do sloupce G2 a nize.
Radne ostestovat, zda dava spravny vysledek.
syd

zdravim,
zde je alespon jeden pokus, ale pomoci userform. Pak kdyz jsem chvili koukal na list Zadani, tak to asi chcete tak, ze makro proje vsechny kriteria a postupne do sloupce G vypise vysledek, ze?
No zkuste, tak jak je, zda to vubec funguje (na tech vasich 1000000 radcich), snad se to podoba tomu, ceho chcete dosahnout.
Uvidime
syd

zdravim,
mozna neco podobneho jsem resil zde:
http://wall.cz/index.php?m=topic&id=32112#post-32125
Treba vas to nakopne...

Pokud ne, tak vzdy nejlepsi poslat ukazku souboru pred a po.

diky
syd

Zdravim,

napr. makrem nize:

Sub test()
'kazda 50. bunka
Const iSTEP As Integer = 50

Dim ws As Worksheet
Dim rng As Range, x As Long, LR As Long

'data na listu1
Set ws = Sheets(1)
'oblast dat je A2:Axxx
Set rng = ws.Range("A2:A" & ws.Range("A" & Rows.Count).End(xlUp).Row)
'posledni bunka v oblasti
LR = ws.Range("A" & Rows.Count).End(xlUp).Row

'pozadovana hodnota je kopirovana do nasledujiciho sloupce
For x = 1 To LR Step iSTEP
rng.Item(x).Offset(0, 1) = rng.Item(x)
Next x

'odstraneni prazdnych bunek
rng.Offset(0, 1).SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End Sub

syd

Zdravim,

napr.:
dim nazevsouboru as string
dim i as integer

for i = 0 to me.listbox1.listcount - 1
if me.listbox1.selected(i) then
nazevsouboru = me.listbox1.list(i)
'zde otevrete soubor a provedete dalsi makro...
Application.Workbooks.Open("C:\Users\mn\Desktop\makro\" & fir & "\" & nazevsouboru)
end if
next i

Je treba cyklus a postupne overit, zda byla polozka vybrana a potom s polozkou pracovat.

syd

No, presene.. Ja byl vcera vecer uz dossst unavenej, a tak jsem menil nastaveni v systemu a v excelu sem a tam snad 4x, abych se ujistil, ze neblaznim...
Nevim, vypada to, ze ve VBE akceptuje pouze US nastaveni, tedy tecku a nezajima ho, jak je nastaveno v excelu.. jen muj nazor..

Ja nastavil ve WIN a v Excelu mam zaskrtnute pouzivat ze systemu.
Viz PM. Musi to jit

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje