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

MS Excel

Téma: Kopírování do jiného listu - s podmínkami

Zaslal/a Fantasyk 2.4.2021 9:08

Zdravím,
potřeboval bych poradit, už si nad tím lámu delší dobu hlavu..

Mám v listu STOP data ( které vkládám makrem ze serveru ), které bych chtěl překopírovat do listu STOPS, ale tak, aby se smazaly duplicitní řádky, ale před tím, když najde ve sloupci "I" stejné číslo chyby , aby sečetlo dané řádky ve sloupci "F" viz přiložený dokument..

list STOP má někdy i 1000 řádků a proto bych to chtěl trochu zredukovat v listu STOPS

Děkuji všem, kteří mě nakopnou nebo pomůžou

Příloha: 50301_stop.xlsx (33kB, staženo 14x)

Zaslat odpověď >

---

Fantasyk(2.4.2021 9:21)#050302

Akurát to nemůžu formátovat jako tabulku, jelikož to bude sdílený souborcitovat

Stalker(2.4.2021 16:38)#050303

Nic lepšího mě nenapadlo, ale je to funkční.
Možná někdo přijde s jednodušším řešením.
Otestuj.

Příloha: 50303_stop.rar (37kB, staženo 17x)

citovat

Fantasyk(2.4.2021 19:50)#050304

Stalker napsal/a:

Nic lepšího mě nenapadlo, ale je to funkční.
Možná někdo přijde s jednodušším řešením.
Otestuj.Příloha: 50303_stop.rar (37kB, staženo 2x)

Mrknu na to zítra v práci, ale každopádně děkuji za ochotu, už se mi podařilo v práci něco "spachtit", ale není to 1OOprocentní..citovat

Fantasyk(3.4.2021 7:38)#050305

funguje přesně jak má jsi šikula ( tohle bych makrem jak to máš nikdy nedal ).

Problém nastane tehdy, když tam je 1000 řádků trvá to strašně dlouho, tak jsem to udělal nakonec takto:

přidal jsem další sloupec:
=SUMIFS($F2:F$2000;$B2:B$2000;B2;$I2:I$2000;I2))
a nakopíroval dolů..

tím pádem mi to sečetlo časy daných chyb.
a pak jsem smazal duplicitní hodnoty


Sheets("STOPS").Select
Columns("A:AA").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("STOP").Select
Columns("A:AA").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells.Select
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$AA$1998").RemoveDuplicates Columns:=Array(2, 3, 9, 10, _
11, 22), Header:=xlYes

pracuje to mnohem rychleji, jen tam je ten sloupec navíc.. ( a jen mi trvalo asi 10 hodin na to přijít )

Ale děkuji mockrát za ochotucitovat

Stalker(3.4.2021 12:51)#050309

Předělal sem vymazávání řádků.
Nyní se mažou všechny až na konci makra.
Teoreticky by se měl průběh zrychlit.

Příloha: 50309_stop-2.rar (38kB, staženo 13x)

citovat

elninoslov(3.4.2021 13:30)#050310

Skúste toto. Neodlaďoval som, ale ak je to na prvú správne, tak neverím, že to bude trvať dlhšie ako 0,5 sek.
Sub DelDup2()
Dim D(), V(), R As Long, RV As Long, i As Long, s As Long, Col As New Collection, Kopiruj As Boolean

With List1
R = .Cells(Rows.Count, 1).End(xlUp).Row - 1
If R = 0 Then MsgBox "No data!", vbExclamation: Exit Sub
D = .Range("A2:Z2").Resize(R).Value
ReDim V(1 To R, 1 To 26)
End With

For i = 1 To R
If IsNumeric(D(i, 9)) Then
On Error Resume Next
Col.Add RV + 1, CStr(D(i, 9))
Kopiruj = Err.Number = 0
On Error GoTo 0
Else
Kopiruj = True
End If

If Kopiruj Then
RV = RV + 1
For s = 1 To 26
V(RV, s) = D(i, s)
Next s
Else
s = Col(CStr(D(i, 9)))
V(s, 6) = V(s, 6) + D(i, 6)
End If
Next i

With List2
Intersect(.Range("A:Z"), .UsedRange.Offset(1, 0).EntireRow).ClearContents
.Cells(2, 1).Resize(R, 26).Value = V
End With
End Subcitovat

Fantasyk(3.4.2021 14:17)#050312

Děkuji moccitovat

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse