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: Výpis hodnot dle měsíce
MS Excel
Téma: Výpis hodnot dle měsíce 
Zaslal/a Baja 16.3.2023 16:39
Zdravím vás, ExcelMágové, mohu vás poprosit o radu? V příloze je jednoduchá vzorová tabulka. Potřeboval bych buď makrem nebo třeba maticovým vzorcem vypsat hodnoty z listu zdroj do listu hledání dle jednoho kritéria, a to měsíce zkoušek.
Dovedete mě nakopnout, prosím?
Děkuji moc, B
Příloha: 
54656_vypis-hodnot-dle-mesice.zip (13kB, staženo 13x)
54656_vypis-hodnot-dle-mesice.zip (13kB, staženo 13x)(16.3.2023 19:00)#054658
nebo takhle:
Option Explicit
Function TransposeArray(MyArray As Variant) As Variant
Dim X As Long
Dim Y As Long
Dim Xupper As Long, Xlower As Long
Dim Yupper As Long, Ylower As Long
Dim tempArray As Variant
Xupper = UBound(MyArray, 2)
Xlower = LBound(MyArray, 2)
Yupper = UBound(MyArray, 1)
Ylower = LBound(MyArray, 1)
ReDim tempArray(Xlower To Xupper, Ylower To Yupper)
For X = Xlower To Xupper
For Y = Ylower To Yupper
tempArray(X, Y) = MyArray(Y, X)
Next Y
Next X
TransposeArray = tempArray
End Function
Sub Hledaj()
Dim shZ As Worksheet, shH As Worksheet
Dim arrZ As Variant, arrTmp() As Variant, arrResult As Variant
Dim lastR As Long, r As Long, iTmp As Long
Dim monthNR As String, strDate As String
monthNR = InputBox("Enter month in format 'MM':", "Enter month")
Set shZ = ThisWorkbook.Sheets("zdroj")
Set shH = ThisWorkbook.Sheets("hledání")
lastR = shH.Cells(Rows.Count, "A").End(xlUp).Row
If lastR > 2 Then
With shH
.Range("A3:D" & lastR).ClearContents
End With
End If
lastR = shZ.Cells(Rows.Count, "A").End(xlUp).Row
arrZ = shZ.Range("A2:E" & lastR)
For r = LBound(arrZ, 1) To UBound(arrZ, 1)
'convert date to string
strDate = CStr(arrZ(r, 5))
If Mid(strDate, 4, 2) = monthNR Then
iTmp = iTmp + 1
ReDim Preserve arrTmp(1 To 4, 1 To iTmp)
arrTmp(1, iTmp) = arrZ(r, 1)
arrTmp(2, iTmp) = arrZ(r, 2)
arrTmp(3, iTmp) = arrZ(r, 3)
arrTmp(4, iTmp) = arrZ(r, 4)
End If
Next r
arrResult = TransposeArray(arrTmp)
With shH
.Range("A3").Resize(UBound(arrResult, 1), UBound(arrResult, 2)) = arrResult
End With
End Sub
citovat
Option Explicit
Function TransposeArray(MyArray As Variant) As Variant
Dim X As Long
Dim Y As Long
Dim Xupper As Long, Xlower As Long
Dim Yupper As Long, Ylower As Long
Dim tempArray As Variant
Xupper = UBound(MyArray, 2)
Xlower = LBound(MyArray, 2)
Yupper = UBound(MyArray, 1)
Ylower = LBound(MyArray, 1)
ReDim tempArray(Xlower To Xupper, Ylower To Yupper)
For X = Xlower To Xupper
For Y = Ylower To Yupper
tempArray(X, Y) = MyArray(Y, X)
Next Y
Next X
TransposeArray = tempArray
End Function
Sub Hledaj()
Dim shZ As Worksheet, shH As Worksheet
Dim arrZ As Variant, arrTmp() As Variant, arrResult As Variant
Dim lastR As Long, r As Long, iTmp As Long
Dim monthNR As String, strDate As String
monthNR = InputBox("Enter month in format 'MM':", "Enter month")
Set shZ = ThisWorkbook.Sheets("zdroj")
Set shH = ThisWorkbook.Sheets("hledání")
lastR = shH.Cells(Rows.Count, "A").End(xlUp).Row
If lastR > 2 Then
With shH
.Range("A3:D" & lastR).ClearContents
End With
End If
lastR = shZ.Cells(Rows.Count, "A").End(xlUp).Row
arrZ = shZ.Range("A2:E" & lastR)
For r = LBound(arrZ, 1) To UBound(arrZ, 1)
'convert date to string
strDate = CStr(arrZ(r, 5))
If Mid(strDate, 4, 2) = monthNR Then
iTmp = iTmp + 1
ReDim Preserve arrTmp(1 To 4, 1 To iTmp)
arrTmp(1, iTmp) = arrZ(r, 1)
arrTmp(2, iTmp) = arrZ(r, 2)
arrTmp(3, iTmp) = arrZ(r, 3)
arrTmp(4, iTmp) = arrZ(r, 4)
End If
Next r
arrResult = TransposeArray(arrTmp)
With shH
.Range("A3").Resize(UBound(arrResult, 1), UBound(arrResult, 2)) = arrResult
End With
End Sub
citovat
1) FILTER je super, akorát v práci mám starší Office a tam smolík :(
Nešlo by to nějak jinak vzorcem, prosím?
2) A makro mi nefunguje :( Asi u mě problém mezi klávesnicí a židlí.
Ale přesto děkuji moc, Bcitovat
Nešlo by to nějak jinak vzorcem, prosím?
2) A makro mi nefunguje :( Asi u mě problém mezi klávesnicí a židlí.
Ale přesto děkuji moc, Bcitovat
Nějak se s makry peru, nešlo by to, prosím, přece jenom maticí?
Dat je přece jenom hodně a já bych si to chtěl udělat za jednotlivé měsíce zvlášť na každém listu pro zpřehlednění.
Děkuji moc, B.citovat
Dat je přece jenom hodně a já bych si to chtěl udělat za jednotlivé měsíce zvlášť na každém listu pro zpřehlednění.
Děkuji moc, B.citovat
(19.3.2023 21:24)#054676
Hravo Ti to vyrieši kontingenčná tabuľka. Nepotrebuješ ani makrá ani maticové vzorcecitovat
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