• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

Příspěvky uživatele

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

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse