Excel VBA - překopírování dat Vyřešeno

[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

[Reklama]

[mmmartin]

ze sloupce A (data) do sloupce A (akce) a ze sloupce B (data) do sloupce B (data))

Opravdu, nebo je to překlep?

[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.

[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

[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 ...

[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.

[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...

[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

[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"

[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 Sub

Snad v procedure nebude chyba vznikla pri uprave.

[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.

[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
....