Stránka 1 z 2
Excel VBA - překopírování dat
Napsal: 28 čer 2010 09:35
od Branscombe
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
Re: Excel VBA - překopírování dat
Napsal: 28 čer 2010 11:20
od mmmartin
ze sloupce A (data) do sloupce A (akce) a ze sloupce B (data) do sloupce B (data))
Opravdu, nebo je to překlep?
Re: Excel VBA - překopírování dat
Napsal: 28 čer 2010 11:28
od mike007
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.
Re: Excel VBA - překopírování dat
Napsal: 28 čer 2010 11:41
od navstevnik
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
Re: Excel VBA - překopírování dat
Napsal: 28 čer 2010 12:32
od Branscombe
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 ...
Re: Excel VBA - překopírování dat
Napsal: 28 čer 2010 16:46
od navstevnik
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.
Re: Excel VBA - překopírování dat
Napsal: 29 čer 2010 07:24
od Branscombe
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...
Re: Excel VBA - překopírování dat
Napsal: 29 čer 2010 08:22
od navstevnik
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:
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
Re: Excel VBA - překopírování dat
Napsal: 29 čer 2010 08:41
od Branscombe
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"
Re: Excel VBA - překopírování dat
Napsal: 29 čer 2010 12:28
od navstevnik
Upravena procedura:
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 SubSnad v procedure nebude chyba vznikla pri uprave.
Re: Excel VBA - překopírování dat
Napsal: 29 čer 2010 13:06
od Branscombe
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.
Re: Excel VBA - překopírování dat
Napsal: 29 čer 2010 17:21
od navstevnik
Pozadoval jsi:
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
....