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

Příspěvky uživatele

Tak už to šlape zakázal jsem a smazal všechny doplňky.
Můžete lock.

Zdravím potřebuji pomoct s chybou Run-time error '1004'
Method 'Add' of object 'Sheets' failed u tohoto makra

Sub LoopThrough()
Dim WSO As Worksheet
Set WSO = ActiveSheet
For Each Cell In WSO.Range("B1:B4019")
ActiveWorkbook.Worksheets.Add
ThisURL = "URL;" & Cell.Value

With ActiveSheet.QueryTables.Add(Connection:= _
ThisURL, Destination:=Range("$A$1"))
.Name = "matchdetails.php?matchid=1405937"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next Cell
End Sub


Vždy to vyhodí tak po 100 až 300 listu.Díky za rady.

Ok děkuju za vysvětlení.

Možná byste mi ještě mohli pomoct když se A1 = 1 A2 = 1
tak mi vyfyltruje 2x 1.Prostě co je v první buňce to excelu nic neříká.

OK děkuju vám.
Nejrychlejší je

Sheets("List1").Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("List2").Range("A1"), Unique:=True

Mno jedná se asi o 4000 hodnot Asi tuším správně že by se to dalo zrychlit použitím něčeho jinýho než Go To a select.Snad mi bude stačit jen ukázání takového směru.
Díky

Zdr@vim.Řeším opět problém a potřebuju vaše rady.

O co jde?
Z listu 1 potřebuju kopírovat hodnoty do listu 2.Ale pokuď se ta hodnota už nachází na listu 2 tak nekopírovat nic a zkusit další hodnotu.

Dám příklad pro uplné vyjasnění

List 1 = Worksheets("List1").Cells(1, 3).Value.= pes
Worksheets("List1").Cells(2, 3).Value.= kočka
Worksheets("List1").Cells(3, 3).Value.= pes

Tak na listu 2 nebude 2x pec ale bude jen
Worksheets("List1").Cells(3, 1).Value.= pes
Worksheets("List1").Cells(3, 2).Value.= kočka

Sub kopiruj()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i As Integer
For i = 1 To 3889
Worksheets("List1").Cells(i, 3).Value = Worksheets("List2").Cells(3, i).Value
Next i
End Sub


Děkuju vám za rady.

Díky za ty rady

Opičáku Děkuju jsi chytrá opice.

Teď vše v pořádku

Sub spocitej()
Celkem_modra = "0"
Celkem_cervena = "0"
Dim sloupec As Integer, radek As Integer
For radek = 1 To 3889
For sloupec = 5 To 20
If (Cells(radek, sloupec).Font.Color = RGB(255, 0, 0)) Then Celkem_cervena = Celkem_cervena + 1
If (Cells(radek, sloupec).Font.Color = RGB(0, 32, 96)) Then Celkem_modra = Celkem_modra + 1
Next sloupec
Cells(radek, 2).Value = Celkem_modra & ":" & Celkem_cervena
Celkem_modra = "0"
Celkem_cervena = "0"
Next radek
End Sub

Tak po přehození nastala změna
Sub spocitej()
Celkem_modra = "0"
Celkem_cervena = "0"
Dim sloupec As Integer, radek As Integer
For radek = 1 To 3889
For sloupec = 5 To 20
If (Cells(radek, sloupec).Font.Color = RGB(255, 0, 0)) Then Celkem_cervena = Celkem_cervena + 1
If (Cells(radek, sloupec).Font.Color = RGB(0, 32, 96)) Then Celkem_modra = Celkem_modra + 1
Next sloupec
Cells(radek, 2).Value = Celkem_modra & ":" & Celkem_cervena
Next radek
End Sub


Ale pamět si pořád pomatuje udáje z předchozích řádků a příčítá je.

Teď víc prohlížím knížku Excel 2007 programování Vba.Narazil jsem na příkaz Exit For tím by se daly ty ckly od sebe oddělit.

Zdravím předem děkuji za váš čas.

Vlastním makro , které jsem si vytvořil.


Sub spocitej()
Celkem_modra = "0"
Celkem_cervena = "0"
Dim sloupec As Integer
For sloupec = 5 To 20
If (Cells(1, sloupec).Font.Color = RGB(255, 0, 0)) Then Celkem_cervena = Celkem_cervena + 1
If (Cells(1, sloupec).Font.Color = RGB(0, 32, 96)) Then Celkem_modra = Celkem_modra + 1
Next sloupec
Cells(1, 2).Value = Celkem_modra & ":" & Celkem_cervena
End Sub


Tohle makro má zadán cykl zkontrolovat řádek 1 od sloupce 5 do sloupce 20 nalézt červené a modré buňky ty sečíst a zapsat do Cells(1, 2).(Funguje to.)

Co potřebuji a pokoušel jsem se o to bez úspěchu ?
Udělat tohle pro všechny řádky automaticky.

----
Pokošel jsem se o to sám.

Sub spocitej()
Celkem_modra = "0"
Celkem_cervena = "0"
Dim sloupec As Integer, radek As Integer
For sloupec = 5 To 20
For radek = 1 To 4000
If (Cells(radek, sloupec).Font.Color = RGB(255, 0, 0)) Then Celkem_cervena = Celkem_cervena + 1
If (Cells(radek, sloupec).Font.Color = RGB(0, 32, 96)) Then Celkem_modra = Celkem_modra + 1
Next sloupec
Cells(radek, 2).Value = Celkem_modra & ":" & Celkem_cervena
Next radek
End Sub


Někde mám totální blbost neumím to zapsat, teď vím že by 2 cykly měli končit zároveň ale jak to napsat ?

Děkuju

Zdravím získávám další a další vědomosti ohledně Vba, učím se rychle ale mám problém.

Potřebuji Upravit makro aby mi zapsalo třeba do Cells(1, 5) tak jako v tomhle stylu Celkem_modra:Celkem_cervena

Jen ujasním že je nechci dělit , chi jen znaménko : mezi ně.

Sub spocitejscore()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Celkem_cervena = "0"
Celkem_modra = "0"
Dim i As Integer
For i = 1 To 30000
If (Cells(i, 1).Font.Color = RGB(255, 0, 0)) Then Celkem_cervena = Celkem_cervena + 1
If (Cells(i, 1).Font.Color = RGB(0, 32, 96)) Then Celkem_modra = Celkem_modra + 1
Next i
Cells(16, 5).Value = Celkem_cervena
Cells(14, 5).Value = Celkem_modra
End Sub

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse