Příspěvky uživatele
< návrat zpět
Ahoj.
Ve sloupci "N" buňky a některé z nich obsahují část textu "EBE".
Potřeboval bych pokud takovou buňku najdu aby do sloupce "S" dopsat slovo "Reklamace".
Asi něco takového (toto mi bohužel nejede jak by mělo)Sub test()
Dim Found As Range, tempcell As Range
Set Found = Columns("N").Find(What:="EBE", lookat:=xlPart)
If Not Found Is Nothing Then
'Found.Offset(0, 5).Range("A1").FormulaR1C1 = "REKLAMACE"
Do
Set tempcell = Columns("N").FindNext
If tempcell Is Nothing Then Exit Do
Set Found = tempcell
Found.Offset(0, 5).Range("A1").FormulaR1C1 = "REKLAMACE"
Loop
End If
End Sub
Pomůže někdo?
Děkuji
Radek
Už to vidím, děkuji.
Nevím proč, ale vždy to havaruje na
Radku = .Cells(Rows.Count, 1).End(xlUp).Row - 1
elninoslov - pochopil jste přesně co jsem potřeboval, ale nechtěl jsem moc otravovat.
Tak jsem na každou vyhledávanou položku ze sloupce "D" napsal zvlášť proceduru.
Vím, že mým způsobem to není optimální, ale v celku to funguje.
Moc díky určitě využiji.
Radek
Ahoj.
Mám list "Urgence" zde potřebuji podbarvit buňky ve sloupci "A", které mají stejnou hodnotu jako buňka "D3" na listu "Strategické díly.
K tomu se snažím použít
For Each cell In Range("A2:A8000")
If cell(s).Value = Sheets("Strategické díly").Range("D3:D3").Value Then
cell(s).Interior.Color = RGB(0, 204, 255)
Else
s = s + 1
End If
Next
Někde je ale chyba.
Poradíte prosím?
Tak chyba mezi klávesnicí a židlí 
.
V tabulce jsem měl filtr na vzestupné řazení. Pokud jsem o půlnoci tabulku promazal, abych dostal druhý den informace jen z následujícího dne, tak je logické, že tabulka neměla co řadit a tak při otevřeni havarovala.
No jo, krok po kroku a člověk na to po delší době přijde někdy i sám
Ahoj všem.
Mám excelový soubor, který ukládám pomocí procedury:
Application.DisplayAlerts = False
ActiveWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = True
Tento soubor je uložen na síťovém serveru a v průběhu dne jsou do něj přidávány řádky s různým textem a čísly.
(sešit se pomocí jiné procedury v jiném sešitu otevře, nakopírují se do něj data, uloží se a zavře.
Cca po 5 takto otevřeních a uloženích pak vyvolávací procedura havaruje na hlášce viz příloha.
Máte prosím někdo podobnou zkušenost? Už se s tím otravuji asi pátý den a pořád dokola.
Používaný Office 2016
Děkuji
Radek
Já jsem tak hloupý, vždyť je to tak jednoduché
Sheets("Prac list").Cells(65536, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Ahoj.
Nevím si rady jak vložit zkopírovaný výběr z jiného listu do do první prázdné buňky ve sloupci "A" na listě "Prac list".
Důvod: procházím cca 20-30 listů, ve kterých odfiltruji určité řádky a to co zůstane potřebuji nakopírovat do Prac list. Následně dělám součty za jednotlivé položky.
Poradíte někdo?
Sub Krok1(x As Boolean, nazev As String)
Set ws = Sheets(nazev)
Set ws1 = Sheets("Prac list")
'zrušit ukotvení
SplitColumn = 0
SplitRow = 0
With ws
If .AutoFilterMode = True And .FilterMode = True Then
'MsgBox "Data jsou filtrovaná. Sešit obsahuje filtr ;)"
.ShowAllData
ElseIf .AutoFilterMode = True Then
'MsgBox "K dispozici filtry - data nefiltrovaná."
Else
'MsgBox "Sešit neobsahuje filtry."
.Range("A1:M1").AutoFilter
End If
End With
'ohraničit řádky a sloupce podle sloupce "C"
Dim lastrowF As Long
lastrow = Cells(Rows.Count, 3).End(xlUp).Row
ws.Range("A1:M" & lastrow).Borders.LineStyle = xlContinuous
'skryje řádky, když je ve sloupci "6" neboli "F" nějaká poznámka
ws.Range("A1:M" & lastrow).AutoFilter Field:=6, Criteria1:="="
'kopíruj viditelné řádky
'ws.Range("A1:M" & lastrow).Copy
'vlož do listu "Prac list" do první prázdné buňky ve sloupci "A"
'ws1.Offset(1, 0).ActiveSheet.Paste
End Sub
tak třeba to už půjde
To je divný, požívám WinRar 5.50
Děkuji za snahu.
Příloha je celou dobu v požadavku.
Nicméně napsaný kód nedělá to co by měl.
aad1) pracuje i se skrytými řádky
add2) pokud je ve sloupci "H"číslo, tak požadovaný řádek nevloží
I tak jsem se snažil napsaným kódem inspirovat, ale to je již pro mě vyšší dívčí 
Pokud by se našel někdo, kdo by se tomu chtěl po věnovat, přikládám opět přílohu.
Děkuji
Radek
Ahoj, opravdu se nenajde nikdo kdo by si s tím dokázal poradit?
Děkuji
Radek
Celá tabulka jak jí vidíte je výsledek procedury, která je volána cca 4x denně. To co je v příloze je výsledek.
Já bych opravdu potřeboval jen udělá to co jste psal.
1)Pokud je změna sloupci "G" = vlož řádek.
2)Pokud jsou čísla ve sloupci "G" stejná, ale vznikne odchylka ve sloupci "I" = vlož řádek.
To oddělování černými řádky co již v tabulce je,mám také v proceduře (zde však přesně definuji názvy "VIP", "Vyškov" atd.., pod kterými se má řádek vložit), tak nemám problém to co případně napíšete, vložit někam nad toto oddělování.
Vzor jak odděluji přesně definované názvy(moc se prosím nesmějte )
Sub NajdiVIP()
HledanaHodnota = "VIP" 'zadej hledanou hodnotu
For i = 3 To 2000
rozsah = "R" & i 'zadej kde hledat
With Range(rozsah)
Set FoundCell = .Cells.Find(What:=HledanaHodnota, _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With
If FoundCell Is Nothing Then
Else
FoundCell.Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Selection.End(xlToLeft).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.FormatConditions.Delete
ActiveCell.Range("A1:AB1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Exit For
End If
Next i
End Sub
S ostatním si asi poradím.
Děkuji
Děkuji za rychlou reakci.
Postačí mi, když bude změna v tomto případě
Takže keď nastane zmena v bunke G5 a zároveň zmena v bunke I5 tak sa medzi riadky 5 a 6 vloží nový riadok ?
Děkuji
Radek
Uživatelské menu
\nMenu
On-line nástroje
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
RSS nejnovější články