Příspěvky uživatele
< návrat zpět
Ahoj.
Stávající podmínka = když je ve sloupci a prázdná buňka doplň "Ostatní"
Potřeboval bych ale ještě složitěji:
když je ve sloupci a prázdná buňka a ve sloupci M je číslo 1 nebo 2 doplň "nákup"
když je ve sloupci a prázdná buňka a ve sloupci M je číslo 3 doplň "prodej"
Pomůže někdo prosím, děkuji?
Sub Ostatni() 'najdi prázdnou buňku ve sloupci "A" a nahraď slovem "Ostatní"
Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String
For i = 0 To Cells(1, Columns.Count).End(xlToLeft).Column
sourceCol = 1 + i
rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
For currentRow = rowCount To 1 Step -1
currentRowValue = Cells(currentRow, sourceCol).Value
If IsEmpty(currentRowValue) Or currentRowValue = "" Or Trim(currentRowValue) = "" Then
Cells(currentRow, sourceCol).Value = "Ostatní"
End If
Next
Next
End Sub
Sice trochu kostrbatě, ale mám to 
Sub seskupit()
Application.ScreenUpdating = True
Application.DisplayAlerts = False
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Celkem" Or ws.Name = "Data" Then
Else
ws.Select
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add2 Key:=Range("B2:B500" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ws.Sort.SortFields.Add2 Key:=Range("C2:C500" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ws.Sort.SortFields.Add2 Key:=Range("D2:D500" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ws.Select
With ws.Sort
.SetRange Range("A1:AR500")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ws.Select
Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Columns("D:D").EntireColumn.NumberFormat = _
"_-* #,##0 _K_č_-;-* #,##0 _K_č_-;_-* ""-"" _K_č_-;_-@_-"
End If
Next ws
Application.DisplayAlerts = True
Application.ScreenUpdating = False
End Sub
Ahoj.
Pro seskupení ve všech listech mino listy Celkem a Data bych chtěl použít toto, ale někdy doběhne a někdy se sekne. Problém bude určitě někde kolem ws.select.
Poradí někdo, děkuji?
Dim ws As Worksheet
Application.ScreenUpdating = True
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Celkem" And ws.Name <> "Data" Then
ws.Select
Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Columns("D:D").EntireColumn.NumberFormat = _
"_-* #,##0 _K_č_-;-* #,##0 _K_č_-;_-* ""-"" _K_č_-;_-@_-"
End If
Next ws
jo jo máte pravdu, chyb jsem tam nechal více a to tím jak jsem to zkoušel při krokování.
Každopádně jsem nyní odzkoušel a šlape dle představ.
Děkuji moc.
Ještě jednou děkuji.
Hází to však chybu ve formátu nakopírovaných datech a kód nedoběhne celý.
Zde se zastaví:
Worksheets(Sheets.Count).Range("A1:AR" & iCil) = arrCil
V příloze jsou data tak, jak tabulka vypadá před zavoláním kódu.
Můžete na to ještě mrknout, prosím?
Děkuji
Dobrý večer a děkuji. Zítra vyzkouším.
Ahoj.
V listě „Celkem" je jmenný seznam a zde důležitý sloupce „Zodpovídá".
V listě „Data" jsou data, která potřebuji roztřídit do jednotlivých listů podle „Zodpovídá“.
Kód by měl vypadat takto (přeloženo do lidského jazyka )
Načti první jméno z listu „Celkem" ze sloupce „A"
Když najdeš toto jméno na listě „Data" ve sloupci „A" tak vyjmout všechny tyto řádky s tímto jménem a vložit je do listu se stejným jménem
(Vzhledem k tomu, že jednotlivé listy a seznam jmen na listu „Celkem" jsou tvořeny právě z listu „Data", musí se vždy alespoň jeden řádek překopírovat).
Takto to proveď u všech jmen z listu „Celkem".
Pomůže prosím někdo?
Děkuji.
Jiří497, děkuji moc.
Sice řadí listy před list celkem ale to si upravím.
Musím říci že o proti prvnímu mému špatnému kódu je finální verze mnohem obsáhlejší a pro mě složitější. Ale jak jsem koukal tak obsahuje i kontrolní mechanizmy, tak za mě cajk.
Děkuji moc.
Ahoj.
Mám v sešitě kontingenční tabulku pokaždé s jiným počtem jmen a potřeboval bych ke každému jménu vytvořit list a podle buňky jej pojmenovat.
Snažím se pomocí tohoto, ale nedaří se.
Pomůže mi někdo, prosím?
Kód rovněž v příloze
Sub Prejmenuj_listy()
Dim rng As Range
Dim cell As Range
Set rng = ActiveSheet.Range("A5:A20")
For Each cell In rng
If cell.Value <> "" Then
Sheets.Add After:=ActiveSheet.Name = cell.Value
ElseIf Cells.Value = "" Then
End
Next cell
End Sub
Ahoj.
Potřebuji dosadit do listu "Zatížení kapacit" do "H7" celkovou hodnotu všech buněk z listu "Laser" sloupce "V:W", které mají datum ve sloupci "T" rovné a mezi datem z listu "Zatížení kapacit" buňka "F4" a "H4".
Snažím se použít =SUMIFS(LASER!V3:W1048576;LASER!T3:T1048576;"=>F4";LASER!T3:T1048576;"=<H4"), ale nedaří se.
Poradí někdo prosím?
Děkuji
Radek
elninoslov - určitě šlo , děkuji.
Jde i toto.
Sub StrategickeDily()
Dim rngUrgence As Range, rngBunka As Range
Dim rngStrategickeDily As Range
With Sheets("Strategické díly")
Set rngStrategickeDily = .Range(.Cells(3, "A"), .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "A"))
End With
With Sheets("Urgence")
Set rngUrgence = .Range(.Cells(2, "C"), .Cells(.Cells(Rows.Count, "C").End(xlUp).Row, "C"))
For Each rngBunka In rngUrgence
If WorksheetFunction.CountIf(rngStrategickeDily, rngBunka.Text) > 0 Then
rngBunka.Interior.Color = RGB(0, 255, 0)
End If
Next
End With
End Sub
Každopádně děkuji všem.
misocko - děkuji za reakci. Pokusil jsem se tedy přihodit viz níže, ale podbarví se jen to co mám na A3 a pak už nic.
If cell(t).Value = Sheets("Strategické díly").Cells(3, 1).Value
Ahoj.
Chtěl bych požádat o pomoc se zacyklováním níže uvedeného.
Potřeboval bych dosáhnout toho, aby pokud v listu "Urgence" v sloupci "C" najdeš hodnotu z listu "Strategické díly" ze sloupce "A" , tak buňku v listě "Urgence" podbarvit zeleně.
Dim lastrowA As Long
lastrowA = Cells(Rows.Count, 1).End(xlUp).Row
t = 1
For Each cell In Range("C2:C" & lastrowA)
If cell(t).Value = Sheets("Strategické díly").Range("A3:A3").Value Then
cell(t).Interior.Color = RGB(0, 255, 0)
Else
t = t + 1
End If
Next
Jinak řečeno, nevím jak nahradit tento omezený výběr
Range("A3:A3").value
Děkuji
Radek
Elninoslov - pracuje to skvěle.
Děkuji moc.
Radek
Tak jsem na to asi došel.
Sub ASI()
Dim lastrowA As Long
lastrowA = Cells(Rows.Count, 1).End(xlUp).Row
Dim Found As Range
Set rng = Range("N1:N" & lastrowA)
Set Found = Columns("N").Find(What:="EBE", lookat:=xlPart)
i = 1
For counter = 1 To rng.Rows.Count
If rng.Cells(i) = Found Then
rng.Cells(i).Offset(0, 5).Range("A1").FormulaR1C1 = "REKLAMACE"
Else
End If
i = i + 1
Next
End Sub
Uživatelské menu
\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