excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: Omezení dat na filtrovanou oblast
MS Excel
Téma: Omezení dat na filtrovanou oblast 
Zaslal/a stejzi 8.11.2017 9:58
Dobrý den,
měl bych dotaz na převod filtrovaných dat. V přiloženém souboru je tlačítko, které převede požadovaný počet řádků (od aktivní buňky) na druhý list. Potřebuji tam dostat aby vzal pouze vyfiltrovaná data a skrytých řádků si nevšímal. Už se s tím mořím několik dní, ale je to nad moje síly.
Příloha: 
38309_pokus.zip (55kB, staženo 36x)
38309_pokus.zip (55kB, staženo 36x)Každopádně je nutné oddělit počitadla řádků pro každý list zvlášť, např.
i = ActiveCell.Row: j = 0
Do While j < Počet
If Rows(i).Hidden = False Then
List2.Range("B8").Offset(j, 0) = Cells(i, 7) 'Typ
List2.Range("D8").Offset(j, 0) = Cells(i, 5) 'číslo
List2.Range("F8").Offset(j, 0) = Cells(i, 2) 'Výrobní číslo
List2.Range("N8").Offset(j, 0) = Cells(i, 6) 'Datum expedice
j = j + 1
End If
i = i + 1
Loop
citovat
i = ActiveCell.Row: j = 0
Do While j < Počet
If Rows(i).Hidden = False Then
List2.Range("B8").Offset(j, 0) = Cells(i, 7) 'Typ
List2.Range("D8").Offset(j, 0) = Cells(i, 5) 'číslo
List2.Range("F8").Offset(j, 0) = Cells(i, 2) 'Výrobní číslo
List2.Range("N8").Offset(j, 0) = Cells(i, 6) 'Datum expedice
j = j + 1
End If
i = i + 1
Loop
citovat
Dd,
upraveno do vaseho kodu. Ale moc to nechapu.
Otestovano jen z rychliku.
Sub Doplnit()
Dim Name As String
Dim Poèet As Long
Dim a As Byte
Dim rMyCell As Range
Application.ScreenUpdating = False
List2.Activate
List2.Range("B8:H19").ClearContents
List2.Range("N8:O19").ClearContents
List3.Activate
Poèet = Application.InputBox("Zadejte poèet øádkù", "Doplnìní dat", , , , , , "1")
Name = List3.Cells(ActiveCell.Row, 8) 'Poslední 4 pozice z èísla zakázky
Name = Right(Name, 4)
List2.Range("N2") = Name
Set rMyCell = ActiveCell
For a = 0 To Poèet - 1
If Rows(rMyCell.Row).Hidden Then
Do
Set rMyCell = rMyCell.Offset(1, 0)
Loop While Rows(rMyCell.Row).Hidden
End If
List2.Range("B8").Offset(a, 0) = List3.Cells(rMyCell.Row, 7) 'Typ
List2.Range("D8").Offset(a, 0) = List3.Cells(rMyCell.Row, 5) 'èíslo
List2.Range("F8").Offset(a, 0) = List3.Cells(rMyCell.Row, 2) 'Výrobní èíslo
List2.Range("N8").Offset(a, 0) = List3.Cells(rMyCell.Row, 6) 'Datum expedice
Set rMyCell = rMyCell.Offset(1, 0)
Next a
Application.ScreenUpdating = True
Sheets("tisk").Select
End Sub
sydcitovat
upraveno do vaseho kodu. Ale moc to nechapu.
Otestovano jen z rychliku.
Sub Doplnit()
Dim Name As String
Dim Poèet As Long
Dim a As Byte
Dim rMyCell As Range
Application.ScreenUpdating = False
List2.Activate
List2.Range("B8:H19").ClearContents
List2.Range("N8:O19").ClearContents
List3.Activate
Poèet = Application.InputBox("Zadejte poèet øádkù", "Doplnìní dat", , , , , , "1")
Name = List3.Cells(ActiveCell.Row, 8) 'Poslední 4 pozice z èísla zakázky
Name = Right(Name, 4)
List2.Range("N2") = Name
Set rMyCell = ActiveCell
For a = 0 To Poèet - 1
If Rows(rMyCell.Row).Hidden Then
Do
Set rMyCell = rMyCell.Offset(1, 0)
Loop While Rows(rMyCell.Row).Hidden
End If
List2.Range("B8").Offset(a, 0) = List3.Cells(rMyCell.Row, 7) 'Typ
List2.Range("D8").Offset(a, 0) = List3.Cells(rMyCell.Row, 5) 'èíslo
List2.Range("F8").Offset(a, 0) = List3.Cells(rMyCell.Row, 2) 'Výrobní èíslo
List2.Range("N8").Offset(a, 0) = List3.Cells(rMyCell.Row, 6) 'Datum expedice
Set rMyCell = rMyCell.Offset(1, 0)
Next a
Application.ScreenUpdating = True
Sheets("tisk").Select
End Sub
sydcitovat
Uživatelské menu
Nejste přihlášen(a)
\n
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články