MS Excel

Téma: Smazání určitých řádků a kopie údajů z databáze

Zaslal/a Gary81 23.11.2018 14:10

Zdravím,
jakým způsobem by bylo možné odstranit řádek za následující podmínky: když buňka ve sloupci E obsahuje nějaký text, a ostatní buňky v řádce jsou prázdné, tak aby se řádek smazal.
Na vysvětlenou, modře označené data jsou zkopírované z informačního systému, a u některých zákazníků se mi stává, že zkopíruje řádek navíc. Je možné použít funkci svyhledat nebo raději makro?
Navíc bych potřeboval zkopírovat jen určitá data, které v systému nejsou. Je možné pomocí nějaké funkce nebo makra udělat to aby například podle buňky D17 se prohledal list, našel se pokud možno nejnovější řádek se stejným registračním číslem, a následně se zkopírovaly data ze sloupců L, O, P, Q, R, S, T?

Předem všem děkuji za jakoukoliv odpověď:)

Zaslat odpověď >

elninoslov(24.11.2018 3:19)#041957

Tak skúste toto:
Sub UpravitData()
Dim Radku As Long, D(), i As Long, ColReg As New Collection, DatumID() As Long, PocetDatum As Long, Poradi As Long, Mazat, Sesit As String, List As String, rngMazat As Range

With ThisWorkbook
Sesit = .Name
With .ActiveSheet
Radku = .Cells(Rows.Count, 5).End(xlUp).Row - 1 'Počet riadkov podľa E
If Radku = 0 Then MsgBox "Žádná data", vbExclamation: Exit Sub
List = .Name
Mazat = Evaluate("=IF((COUNTIF(OFFSET('[" & Sesit & "]" & List & "'!A1:U1,ROW(1:" & Radku & "),),""<>"")<2)*('[" & Sesit & "]" & List & "'!E2:E" & Radku + 1 & "<>""""),TRUE,FALSE)") 'Zistiť, ktoré mazať
ReDim D(1 To Radku, 1 To 21)
D = .Cells(2, 1).Resize(Radku, 21).Value 'Načítať data do poľa

On Error Resume Next
For i = 1 To Radku
If Mazat(i, 1) Then 'Ak mazať riadok, pridať ho na zmazanie
If rngMazat Is Nothing Then Set rngMazat = .Cells(i + 1, 1) Else Set rngMazat = Union(rngMazat, .Cells(i + 1, 1))
End If

Poradi = ColReg(CStr(D(i, 4))) 'Zistiž poradie v kolekcii registračných čísel
If Err.Number <> 0 Then 'Ak ešte nieje v kolekcii, doplň ho, a ulož pozíciu dátumu
Err.Clear
PocetDatum = PocetDatum + 1
Poradi = PocetDatum
ColReg.Add Poradi, CStr(D(i, 4))
ReDim Preserve DatumID(1 To PocetDatum)
DatumID(PocetDatum) = i
Else
If D(i, 21) > D(DatumID(Poradi), 21) Then DatumID(Poradi) = i 'Ak v kolekcii je, porovnaj predošlý a aktuálny riadok dátumu, novší index ulož
End If
Next i
On Error GoTo 0

For i = 1 To Radku 'Upraviť údaje podľa najnonších dátumov
Poradi = DatumID(ColReg(CStr(D(i, 4))))
If IsEmpty(D(i, 12)) Then D(i, 12) = D(Poradi, 12)
If IsEmpty(D(i, 15)) Then D(i, 15) = D(Poradi, 15)
If IsEmpty(D(i, 16)) Then D(i, 16) = D(Poradi, 16)
If IsEmpty(D(i, 17)) Or D(i, 17) = "-" Then D(i, 17) = D(Poradi, 17)
If IsEmpty(D(i, 18)) Or D(i, 18) = "-" Then D(i, 18) = D(Poradi, 18)
If IsEmpty(D(i, 19)) Or D(i, 19) = "-" Then D(i, 19) = D(Poradi, 19)
If IsEmpty(D(i, 20)) Or D(i, 20) = "-" Then D(i, 20) = D(Poradi, 20)
Next i

.Cells(2, 1).Resize(Radku, 21).Value = D 'Vrátiť do listu upravené údaje
End With
End With

If Not rngMazat Is Nothing Then rngMazat.EntireRow.Delete 'Vymazať riadky
End Sub

Příloha: zip

41957_41951_podklady-pro-tvorbu-protokolu.zip (28kB, staženo 385x)

citovat

Gary81(29.11.2018 10:34)#042003

Děkuji moc, nečekal jsem tak rychlou reakci:) Vyzkouším, a dám vědět jak šlape:)citovat

Gary81(18.12.2018 14:26)#042151

Tak jsem to zkoušel, ale zjistil jsem, že jsem sem měl dát kompletní tabulku, dal jsem sem jen ořezanou verzi, nechtěl jsem sem dávat interní data firmy, takže u ořezené verze to funguje, ale když dám makro do používané tabulky, tak to nejde, a nepřišel jsem na to proč. Omlouvám se. Dal jsem sem ještě jednou celou tabulku, jen jsem přepsal některé citlivé data. Mohl by se na to ještě někdo prosím podívat kde je chyba. Potřebuji smazat prázdné řádky, a následně kopírovat data ze sloupců s červeným písmem.

Děkuji:)citovat

Téma: Smazání určitých řádků a kopie údajů z databáze

Uživatelské menu

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura IV

Aktivní diskuse

Čas od do

Čas od do

Čas od do

Čas od do

Makro smyčka

Makro smyčka

Makro smyčka