< návrat zpět
MS Excel
Téma: Pomoc se vzorcem VBA 
Zaslal/a Plavacek 11.7.2014 9:15
Zdravím, potřeboval bych pomoc s upravením vzorce. Už si nevím rady.
Mám ve sloupci A texty a ve sloupcích E:SA mám jednicky až do řádku 1745. Potřebuju, aby se vypsali ty texty, u kterých je v jednotlivých sloupcích jednička do E:SA 1748. (Tedy pro každý sloupec)
Mám k dispozici vzorec VBA, který to dokáže udělat pro jeden sloupec E ... mohli byste mi ale pomoct s tím, aby to bylo pro všechny sloupce? Díky.
Sub Vypis()
Dim Numbers() As Variant
Dim Texts() As Variant
Dim List() As Variant
Dim CountNumbers As Long
Dim i As Long, j As Long
With ActiveSheet
Texts = .Range("A3:A1745").Value
Numbers = .Range("E3:E1745").Value2
CountNumbers = WorksheetFunction.CountIf(ActiveSheet.Range("E3:E1745"), "1")
If CountNumbers = 0 Then GoTo TheEND
ReDim List(1 To CountNumbers, 1 To 1)
j = 0
For i = LBound(Numbers) To UBound(Numbers)
If Numbers(i, 1) = 1 Then
j = j + 1
List(j, 1) = Texts(i, 1)
If j = CountNumbers Then Exit For
End If
Next
.Range("E1748").Resize(CountNumbers, 1).Value = List
End With
TheEND:
End Sub
Dingo(11.7.2014 14:03)#020468 
To je zajímavý kód, zase jsem se něco přiučil. Mohlo by to fungovat takhle:
Sub Vypis()
Dim Numbers() As Variant
Dim Texts() As Variant
Dim List() As Variant
Dim CountNumbers As Long
Dim i As Long, j As Long, k As Long
With ActiveSheet
For k = 5 To 495
Texts = .Range("A3:A1745").Value
Numbers = .Range(Cells(3, k), Cells(1745, k)).Value2
CountNumbers = WorksheetFunction.CountIf(ActiveSheet _
.Range(Cells(3, k), Cells(1745, k)), "1")
If CountNumbers = 0 Then GoTo TheEND
ReDim List(1 To CountNumbers, 1 To 1)
j = 0
For i = LBound(Numbers) To UBound(Numbers)
If Numbers(i, 1) = 1 Then
j = j + 1
List(j, 1) = Texts(i, 1)
If j = CountNumbers Then Exit For
End If
Next i
.Cells(1748, k).Resize(CountNumbers, 1).Value = List
Next k
End With
TheEND:
End SubcitovatPlavacek(11.7.2014 15:15)#020469 hm, nějak to nefunguje
CountNumbers = WorksheetFunction.CountIf(ActiveSheet _
.Range(Cells(3, k), Cells(1745, k)), "1")citovatkp57(11.7.2014 19:14)#020470 Řekl bych, že s těmi poli jsi trochu mimo.
Sub Vypis_2()
Dim rdR As Long, rdW As Long
Dim xRow As Long, yRow As Long
Dim xCol As Long, yCol As Long
Dim xyCols As Range, sumCols As Integer
xRow = 3: yRow = 1745
xCol = 5: yCol = 495
sumCols = yCol - xCol + 1
rdW = yRow + 3
With ActiveSheet
Set xyCols = .Range(.Columns(xCol), .Columns(yCol))
For rdR = xRow To yRow
If WorksheetFunction.CountIf(Intersect(.Rows(rdR), xyCols), 1) = sumCols Then
rdW = rdW + 1
.Cells(rdW, 1) = .Cells(rdR, 1)
End If
Next rdR
End With
Set xyCols = Nothing
End Sub
citovatPlavacek(11.7.2014 20:39)#020474 kp57 napsal/a:
Řekl bych, že s těmi poli jsi trochu mimo.Sub Vypis_2()
Dim rdR As Long, rdW As Long
Dim xRow As Long, yRow As Long
Dim xCol As Long, yCol As Long
Dim xyCols As Range, sumCols As Integer
xRow = 3: yRow = 1745
xCol = 5: yCol = 495
sumCols = yCol - xCol + 1
rdW = yRow + 3
With ActiveSheet
Set xyCols = .Range(.Columns(xCol), .Columns(yCol))
For rdR = xRow To yRow
If WorksheetFunction.CountIf(Intersect(.Rows(rdR), xyCols), 1) = sumCols Then
rdW = rdW + 1
.Cells(rdW, 1) = .Cells(rdR, 1)
End If
Next rdR
End With
Set xyCols = Nothing
End Sub
Tohle nefunguje :(
Můžu se zeptat? K čemu je tohle
xCol = 5: yCol = 495citovatDingo(11.7.2014 20:53)#020476 Co konkrétně na tom mém řešení nefunguje? Mám sestavený mírně testovací soubor a nevšim jsem si, že by to hlásilo chybu, i výsledky to píše, dle mého správně.
Leda tam je špatně zeditováno to rozdělení do dvou řádků tím podrtžítkem !
Viz příloha. Data jsou nesouvislá, sem tam, ale pokryjí rozsah ř /sl.
Na List2 je to řešení Kp57 a to nic nedělá, blíž jsem nezkoumal. Sory.
Vyzkoušej a ozvi se.
Příloha: 
20476_vba_vypis_textu_2.zip (23kB, staženo 20x) citovatkp57(11.7.2014 21:31)#020479 Aha! Špatně jsem pochopil zadání. A ty pole mě překvapily. Dingo funguje. Omlouvám se.
citovatmarjankaj(11.7.2014 21:42)#020480 Zdravím, potřeboval bych pomoc s upravením vzorce. Už si nevím rady.
Mám ve sloupci A texty a ve sloupcích E:SA mám jednicky až do řádku 1745. Potřebuju, aby se vypsali ty texty, u kterých je v jednotlivých sloupcích jednička do E:SA 1748. (Tedy pro každý sloupec)
No ak sú v bunkách E1:SA1745 samé jednotky, ako si uviedol, tak teda nie je čo riešiť. Čo keby si radšej priložil tvoj súbor, aby bolo vidieť ako vyzerá zadanie a aj to ako by mal vyzerať výsledok?
citovatPlavacek(14.7.2014 10:13)#020508 Vidím, že sem asi nebyl přesně pochopen. V těch sloupcích nejsou samé jedničky.
Posílám ten soubor, to bude asi nejlepší.
Prostě a jednoduše. Potřebuju aby ten výpis, který je napsaný ve VBA a vypisuje jen ve sloupci E1748, tak aby byl stejným způsobem udělaný pro všechny zbývající sloupce.
citovatPlavacek(14.7.2014 10:17)#020509 Soubor zde
Příloha: 20509_sample35.rar (79kB, staženo 21x) citovatDingo(14.7.2014 10:57)#020511 TAK JEŠTĚ JEDNOU. Se vzorovým souborem jsem udělal JEN toto: smazal původní makro, nakopíroval nové makro z mého příspěvku z 11.7., zeditoval chybu tam, kde je řádek rozdělený podtržítkem a FUNGUJE to.
Příloha: 20511_sample35.zip (93kB, staženo 22x) citovat
RSS nejnovější články