Ahoj, měl bych opět malý dotaz na makro které mi překopíruje data.
Vzorový soubor v příloze.
Potřebuji aby se mi překopírovali data z listu "data" na list "akce" (ze sloupce A (data) do sloupce A (akce) a ze sloupce B (data) do sloupce B (data)). Podmínka je aby se překopírovali pouze data jenž ještě na listu "akce" nejsou (dle sloupce "B") anebo mají ve sloupci stav (sloupec "J") číslo 4.
Jo a na závěr ještě nějaké stejné formátování řádků jako je teď...
Doufám že jsem to vysvětlil správně a na nic nezapoměl. Díky předem
Excel VBA - překopírování dat Vyřešeno
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Excel VBA - překopírování dat
- Přílohy
-
- akce.zip
- (8.12 KiB) Staženo 19 x
- mmmartin
- Moderátor
-
Elite Level 10
- Příspěvky: 9507
- Registrován: srpen 04
- Bydliště: Praha
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
Opravdu, nebo je to překlep?ze sloupce A (data) do sloupce A (akce) a ze sloupce B (data) do sloupce B (data))
ASUS Prime Z390-P / Hexa Core Intel core i5 Coffee Lake-S / Gigabyte GeForce GTX 650 Ti / FORTRON BlueStorm Bronze 80PLUS / W 11
- mike007
- Master Level 7.5
- Příspěvky: 5860
- Registrován: srpen 07
- Bydliště: Pardubice
- Pohlaví:
- Stav:
Offline
- Kontakt:
Re: Excel VBA - překopírování dat
Branscombe: Když se tak dívám na tvoje příspěvky, tak zde neřešíš nic jiného než VBA ...
Co by se stalo, kdyby ti nikdo nepomohl, vyhodili by tě z práce??? Přijde mi totiž, že se programováním živíš, ale nic neumíš. Jinak si to neumím vysvětlit
Sorry za OT.
Co by se stalo, kdyby ti nikdo nepomohl, vyhodili by tě z práce??? Přijde mi totiž, že se programováním živíš, ale nic neumíš. Jinak si to neumím vysvětlit
Sorry za OT.
Nejlepší hra je Excel!
• Pravidla fóra PC-help • Jak označit téma za vyřešené
»»»»»»»»»»»»»»»»»»»»»»»
UPOZORNĚNÍ - můj Skype, Soukromé zprávy či email neslouží jako tech. podpora.
Dotazy pište do fóra. Od toho tu je.
• Pravidla fóra PC-help • Jak označit téma za vyřešené
»»»»»»»»»»»»»»»»»»»»»»»
UPOZORNĚNÍ - můj Skype, Soukromé zprávy či email neslouží jako tech. podpora.
Dotazy pište do fóra. Od toho tu je.
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
Pozadovane resi procedura vlozena do standardniho modulu sesitu akce.xlsm (pridne dopln klavesovou zkratku pro volani):
Kód: Vybrat vše
Option Explicit
Sub CopyData()
Dim SBlk As Range, SCll As Range, Cpy1 As Boolean, Cpy2 As Boolean
Dim TBlk As Range, TCll As Range, NCll As Range
With Worksheets("data") ' zdrojovy blok
Set SBlk = .Range("b2:b" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
' pro kazdou bunku zdroje prohledat sloupec B:B na akce
For Each SCll In SBlk.Cells
With Worksheets("akce") ' cilovy blok
Set TBlk = .Range("b6:b" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
Cpy1 = True: Cpy2 = False
For Each TCll In TBlk.Cells
' podminky
If TCll.Value = SCll.Value Then Cpy1 = False
If TCll.Value = SCll.Value And TCll.Offset(0, 8).Value = 4 Then Cpy2 = True
Next TCll
If Cpy1 Or Cpy2 Then
' prvni volny radek na akce
With Worksheets("akce")
Set NCll = .Cells(Rows.Count, "b").End(xlUp).Offset(1, 0)
End With
' kopirovat
NCll.Offset(0, -1).Value = SCll.Offset(0, -1).Value
NCll.Value = SCll.Value
' kopirovat format ze zdroje
SCll.Resize(1, 2).Offset(0, -1).Copy
NCll.Offset(0, -1).PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
Set NCll = Nothing
End If
Next SCll
Set SBlk = Nothing
Set SCll = Nothing
Set TBlk = Nothing
Set TCll = Nothing
End Sub
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
to navstevnik: Díky moc, ale asi jsem se špatně vyjádřil nebo je to trošku složitější, ale pakliže mám ve sloupci "B" třeba "hrušky" se stavem "4" tak se data překopírují. Pakliže ale mám ve sloupci "B" "hrušky" se stavem "4" a níže hrušky se stavem "3" tak se data už nekopírují, jelikož jednou už tam hrušky bez stavu "4" jsou...
to mike007: Máš pravdu, neřeším zde nic jiného než VBA, ale kdyby mi nikdo nepomohl tak by mě z práce nevyhodili. Jsem prostý quality engineer který se snaží ve firmě něco zlepšit. Kdysi jsem si vytvořil svůj systém pro pracovníky ve výrobě a teď ho zdokonaluji a zdokonaluji... Kdyby mi nikdo z Vás neporadil tak bych to musel vymyslet tak jak bych byl já sám schopný. Vždy se snažím každou proceduru pochopit abych příště už nemusel otravovat, ale je to asi běh na dlouhou trať... Programuju si tady ten "svůj" systém ve volných chvílích a nic za to nemám, takže sice nic neumím, ale neživím se tím ...
to mike007: Máš pravdu, neřeším zde nic jiného než VBA, ale kdyby mi nikdo nepomohl tak by mě z práce nevyhodili. Jsem prostý quality engineer který se snaží ve firmě něco zlepšit. Kdysi jsem si vytvořil svůj systém pro pracovníky ve výrobě a teď ho zdokonaluji a zdokonaluji... Kdyby mi nikdo z Vás neporadil tak bych to musel vymyslet tak jak bych byl já sám schopný. Vždy se snažím každou proceduru pochopit abych příště už nemusel otravovat, ale je to asi běh na dlouhou trať... Programuju si tady ten "svůj" systém ve volných chvílích a nic za to nemám, takže sice nic neumím, ale neživím se tím ...
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
Porad se to opakuje, nejasna nebo neuplna definice pozadavku.
Priloz jeste jednou soubor, ktery bude na listu akce i data obsahovat vsechny mozne pripady a v pomocnem sloupci uved, co kopirovat a proc anebo si sam uprav cast drive prilozene procedury:
Ve smycce je prochazen blok akce!B6:Bxx a jsou nastavovany logicke promenne Cpy1 a Cpy2 podle zadanych podminek:
For Each TCll In TBlk.Cells
' podminky
If TCll.Value = SCll.Value Then Cpy1 = False
If TCll.Value = SCll.Value And TCll.Offset(0, 8).Value = 4 Then Cpy2 = True
Next TCll
a pote pri splneni je kopirovan zaznam.
PS.: A nepouzivej slucovane bunky, je to sice hezke, ale prinaseji zbytecne komplikace ve VBA.
Priloz jeste jednou soubor, ktery bude na listu akce i data obsahovat vsechny mozne pripady a v pomocnem sloupci uved, co kopirovat a proc anebo si sam uprav cast drive prilozene procedury:
Ve smycce je prochazen blok akce!B6:Bxx a jsou nastavovany logicke promenne Cpy1 a Cpy2 podle zadanych podminek:
For Each TCll In TBlk.Cells
' podminky
If TCll.Value = SCll.Value Then Cpy1 = False
If TCll.Value = SCll.Value And TCll.Offset(0, 8).Value = 4 Then Cpy2 = True
Next TCll
a pote pri splneni je kopirovan zaznam.
PS.: A nepouzivej slucovane bunky, je to sice hezke, ale prinaseji zbytecne komplikace ve VBA.
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
No spíš jsme se jen nepochopili. Zkoušel jsem si s tím trošku hrát, ale marně...
podmínky jsou:
1. Když není ve sloupci "B" stejná hodnota, zkopíruj data (If TCll.Value = SCll.Value Then Cpy1 = False)
2. Když je již stejná hodnota ve sloupci "B" a ve sloupci "J" je 4, zkopíruj data (If TCll.Value = SCll.Value And TCll.Offset(0, .Value = 4 Then Cpy2 = True)
3. Když je již stejná hodnota ve sloupci "B" a ve sloupci "J" není 4, nekopíruj data
Problém proč mi to asi nejde upravit je ten že procedura vyhledává řádek po řádku, ale pakliže budu mít stejný záznam o pár řádků dole s jinou hodnotou ve sloupci "J" tak vznikne problém.
Soubor s možnostmi v příloze. Ve výsledku by měl překopírovat pouze "višně" a "pomelo", jelikož ostatní mají výše status menší než 4...
podmínky jsou:
1. Když není ve sloupci "B" stejná hodnota, zkopíruj data (If TCll.Value = SCll.Value Then Cpy1 = False)
2. Když je již stejná hodnota ve sloupci "B" a ve sloupci "J" je 4, zkopíruj data (If TCll.Value = SCll.Value And TCll.Offset(0, .Value = 4 Then Cpy2 = True)
3. Když je již stejná hodnota ve sloupci "B" a ve sloupci "J" není 4, nekopíruj data
Problém proč mi to asi nejde upravit je ten že procedura vyhledává řádek po řádku, ale pakliže budu mít stejný záznam o pár řádků dole s jinou hodnotou ve sloupci "J" tak vznikne problém.
Soubor s možnostmi v příloze. Ve výsledku by měl překopírovat pouze "višně" a "pomelo", jelikož ostatní mají výše status menší než 4...
- Přílohy
-
- akce.xlsm
- (18.51 KiB) Staženo 25 x
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
Pokusim se to preformulovat:
Polozku prekopirovat, kdyz (ve sloupci B neni shoda) nebo (je shoda ve sloupci B a ve sloupci J je 4 a zaroven neni jina shoda ve sloupci B, kde ve sloupci J neni 4).
Pokud se mi to podarilo spravne, pak by mela vyhovet procedura:
Polozku prekopirovat, kdyz (ve sloupci B neni shoda) nebo (je shoda ve sloupci B a ve sloupci J je 4 a zaroven neni jina shoda ve sloupci B, kde ve sloupci J neni 4).
Pokud se mi to podarilo spravne, pak by mela vyhovet procedura:
Kód: Vybrat vše
Option Explicit
Sub CopyData()
Dim SBlk As Range, SCll As Range, Cpy1 As Boolean, Cpy2 As Boolean
Dim TBlk As Range, TCll As Range, NCll As Range
With Worksheets("data") ' zdrojovy blok
Set SBlk = .Range("b2:b" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
' pro kazdou bunku zdroje prohledat sloupec B:B na akce
For Each SCll In SBlk.Cells
With Worksheets("akce") ' cilovy blok
Set TBlk = .Range("b6:b" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
Cpy1 = True: Cpy2 = False
For Each TCll In TBlk.Cells
' podminky - shoda pro sloupce B:B. v J:J <>4
If TCll.Value = SCll.Value And TCll.Offset(0, 8).Value <> 4 Then Cpy1 = False
' podminky - shoda pro sloupce B:B. v J:J =4
If TCll.Value = SCll.Value And TCll.Offset(0, 8).Value = 4 Then Cpy2 = True
Next TCll
If (Cpy1 And Not Cpy2) Or (Cpy1 And Cpy2) Then
' prvni volny radek na akce
With Worksheets("akce")
Set NCll = .Cells(Rows.Count, "b").End(xlUp).Offset(1, 0)
End With
' kopirovat
NCll.Offset(0, -1).Value = SCll.Offset(0, -1).Value
NCll.Value = SCll.Value
' kopirovat format ze zdroje
SCll.Resize(1, 2).Offset(0, -1).Copy
NCll.Offset(0, -1).PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
End If
Next SCll
Set NCll = Nothing
Set SBlk = Nothing
Set SCll = Nothing
Set TBlk = Nothing
Set TCll = Nothing
End Sub
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
8:45
Super, funguje jak má, ještě to ozkouším ...
Při svých pokusech o modifikaci jsem byl blízko akorát jsem nepoužil "If (Cpy1 And Not Cpy2)"
9:36
Ups... Ještě jsem odhalil malý zádrhel. ;-D Se skoro už bojím to napsat, ale když já to dopředu nevěděl...
Potřeboval bych aby to makro pracovalo s daty od spodu zdroje na listu "Data", tak aby když budou ve zdroji dva stejné záznamy aby překopíroval ten záznam který je nejníže tzn. s vyšším pořadovým číslem.
v přiloženém souboru by měl zkopírovat záznam "višně" s pořadovým číslem "11"
Super, funguje jak má, ještě to ozkouším ...
Při svých pokusech o modifikaci jsem byl blízko akorát jsem nepoužil "If (Cpy1 And Not Cpy2)"
9:36
Ups... Ještě jsem odhalil malý zádrhel. ;-D Se skoro už bojím to napsat, ale když já to dopředu nevěděl...
Potřeboval bych aby to makro pracovalo s daty od spodu zdroje na listu "Data", tak aby když budou ve zdroji dva stejné záznamy aby překopíroval ten záznam který je nejníže tzn. s vyšším pořadovým číslem.
v přiloženém souboru by měl zkopírovat záznam "višně" s pořadovým číslem "11"
- Přílohy
-
- akce.xlsm
- (18.64 KiB) Staženo 23 x
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
Upravena procedura:
Snad v procedure nebude chyba vznikla pri uprave.
Kód: Vybrat vše
Option Explicit
Sub CopyData()
Dim SBlk As Range, SCll As Range, OfsR As Integer
Dim Cpy1 As Boolean, Cpy2 As Boolean
Dim TBlk As Range, TCll As Range, NCll As Range
With Worksheets("data") ' zdrojovy blok
Set SBlk = .Range("b2:b" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
' pro kazdou bunku zdroje prohledat sloupec B:B na akce
With SBlk
OfsR = .Rows.Count - 1 ' ofset posledniho radku zdrojoveho bloku
Set SBlk = .Resize(1, 1) ' modifikovany zdrojovy blok
End With
Do While OfsR >= 0 ' smycka prochazi zdrojovy sloupec
Set SCll = SBlk.Offset(OfsR, 0) ' zdrojova bunka
With Worksheets("akce") ' cilovy blok
Set TBlk = .Range("b6:b" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
Cpy1 = True: Cpy2 = False
For Each TCll In TBlk.Cells ' prohledat cilovy blok
' podminky - shoda pro sloupce B:B. v J:J <>4
If TCll.Value = SCll.Value And TCll.Offset(0, 8).Value <> 4 Then Cpy1 = False
' podminky - shoda pro sloupce B:B. v J:J =4
If TCll.Value = SCll.Value And TCll.Offset(0, 8).Value = 4 Then Cpy2 = True
Next TCll
If (Cpy1 And Not Cpy2) Or (Cpy1 And Cpy2) Then
' prvni volny radek na akce
With Worksheets("akce")
Set NCll = .Cells(Rows.Count, "b").End(xlUp).Offset(1, 0)
End With
' kopirovat
NCll.Offset(0, -1).Value = SCll.Offset(0, -1).Value
NCll.Value = SCll.Value
' kopirovat format ze zdroje
SCll.Resize(1, 2).Offset(0, -1).Copy
NCll.Offset(0, -1).PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
End If
OfsR = OfsR - 1
Loop
Set NCll = Nothing
Set SBlk = Nothing
Set SCll = Nothing
Set TBlk = Nothing
Set TCll = Nothing
End Sub
Snad v procedure nebude chyba vznikla pri uprave.
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
Super, jen mi to teď řadí data sestupně. Nešlo by to vzestupně ?? Mám teď nejvyšší pořadové číslo na prvním vkládaném řádku. :-/
Jestli ne, tak to prostě vložím někam jinam, setřídím vzestupně a překopíruji.
Jestli ne, tak to prostě vložím někam jinam, setřídím vzestupně a překopíruji.
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: Excel VBA - překopírování dat
Pozadoval jsi:
Takze je nabiledni, ze zaznamy budou na list alce prenaseny od posledniho po nejprvnejsi, o potrebe vzestupneho razeni nebyla zminka, v prilozenem souboru z 29.6. zaznamy na listu akce nejsou setrideny.
Dopln si proceduru :
Potřeboval bych aby to makro pracovalo s daty od spodu zdroje na listu "Data"...
Takze je nabiledni, ze zaznamy budou na list alce prenaseny od posledniho po nejprvnejsi, o potrebe vzestupneho razeni nebyla zminka, v prilozenem souboru z 29.6. zaznamy na listu akce nejsou setrideny.
Dopln si proceduru :
Kód: Vybrat vše
....
OfsR = OfsR - 1
Loop
' setridit zaznamy na listu akce
With Worksheets("akce") ' cilovy blok
Set TBlk = .Range("a6:a" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
TBlk.Resize(TBlk.Rows.Count, 10).Sort Key1:=Range("A6"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Set NCll = Nothing
....
-
- Mohlo by vás zajímat
- Odpovědi
- Zobrazení
- Poslední příspěvek
-
- 16
- 6701
-
od mirekol
Zobrazit poslední příspěvek
20 říj 2023 08:31
-
- 5
- 2765
-
od mmmartin
Zobrazit poslední příspěvek
13 črc 2023 18:44
-
- 2
- 1973
-
od honzzicek
Zobrazit poslední příspěvek
01 črc 2023 08:57
-
-
Excel komparacedvou soborů Příloha(y)
od teichmann.ondrej » 15 dub 2024 17:26 » v Kancelářské balíky - 11
- 3494
-
od teichmann.ondrej
Zobrazit poslední příspěvek
22 dub 2024 15:45
-
-
- 1
- 611
-
od Grimm
Zobrazit poslední příspěvek
12 bře 2024 21:43
Kdo je online
Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 8 hostů