Akurát to nemůžu formátovat jako tabulku, jelikož to bude sdílený souborcitovat
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: Kopírování do jiného listu - s podmínkami
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
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 15x)
50301_stop.xlsx (33kB, staženo 15x)Nic lepšího mě nenapadlo, ale je to funkční.
Možná někdo přijde s jednodušším řešením.
Otestuj.
Možná někdo přijde s jednodušším řešením.
Otestuj.
Příloha: 
50303_stop.rar (37kB, staženo 18x)
citovat50303_stop.rar (37kB, staženo 18x)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
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
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
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.
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 14x)
citovat50309_stop-2.rar (38kB, staženo 14x)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
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
Uživatelské menu
Nejste přihlášen(a)
\n
\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