Excel VBA - překopírování dat

[Branscombe]

Ahoj díky moc, setřídění vyřeším tedy jinak ...

Narazil jsem na další potřebnou úpravu makra. Vím že jsem to měl napsat už na začátku, ale to jsem to bohužel ještě netušil ... :-/
Potřeboval bych upravit makro tak abych z listu "Data" kopíroval sloupce A,B a D do A, B a C.
Zkoušel jsem to upravovat sám, ale beznadějně tak bych si rád nechal poradit ... :-/

[navstevnik]

Upravena procedura vcetne drive pozadovaneho setrideni na listu Akce:

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 data
      NCll.Offset(0, -1).Value = SCll.Offset(0, -1).Value  ' ze sloupce A do A
      NCll.Value = SCll.Value  ' ze sloupce B do B
      ' kopirovat format z A:B
      SCll.Resize(1, 2).Offset(0, -1).Copy
      NCll.Offset(0, -1).PasteSpecial Paste:=xlFormats
      Application.CutCopyMode = False
      ' kopirovat data ze sloupce E do C
      NCll.Offset(0, 1).Value = SCll.Offset(0, 2).Value 
      ' kopirovat format z E
      SCll.Resize(1, 1).Offset(0, 2).Copy
      NCll.Offset(0, 1).PasteSpecial Paste:=xlFormats
      Application.CutCopyMode = False
    End If
    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
  Set SBlk = Nothing
  Set SCll = Nothing
  Set TBlk = Nothing
  Set TCll = Nothing
End Sub

PS: vsadil jsem boty, ze to neni posledni pozadavek na upravu, tak se snaz

[Branscombe]

Ahoj, díky moc za makro, zatím vše funguje jak má ... Já doufám že už to byl poslední požadavek, ale kdo ví ještě uvidíme ...

[Branscombe]

No tak aby jsi neprohrál sázku a nemusel chodit bos, tak bych potřeboval buď doplnit předchozí makro nebo zapsat nové, nevím co je lepší a výhodnější.
Potřeboval bych překopírovat buňky z listu "Akce" na list "Data", pouze z řádků kde ve sloupci "G" je cokoliv napsáno. Buňky ze sloupce z A do F, z B do I, z C do G, z G do J a do sloupce H vložit vzorec (třeba =A1; vzorec si pak upravím)

vzorový příklad v příloze

Díky moc předem za námahu

[navstevnik]

Jsem rad, ze mi zustanou boty, neb za poskytovane rady si nove nekoupim
Nize je samostatna procedura, ktera z listu akce prenese na list data obsah zadanych bunek (nejsou osetreny pripadne kolizni stavy v dusledku nekorektniho postupu uzivatele):

Kód: Vybrat vše

Sub CopyDataAkceToData()
  Dim SBlk As Range, SCll As Range
  Dim TCll As Range, TOfsR As Long
  With Worksheets("akce")  ' zdrojovy blok
    Set SBlk = .Range("a6:a" & .Cells(Rows.Count, 1).End(xlUp).Row)
  End With
  Set TCll = Worksheets("data").Range("f2")
  ' prochazet ve smycce list akce a kopirovat prislusne sloupce
  TOfsR = 0
  For Each SCll In SBlk.Cells
    If SCll.Offset(0, 6).Value <> vbNullString Then
      With TCll
        .Offset(TOfsR, 0).Value = SCll.Offset(0, 0).Value
        .Offset(TOfsR, 3).Value = SCll.Offset(0, 1).Value
        .Offset(TOfsR, 1).Value = SCll.Offset(0, 2).Value
        .Offset(TOfsR, 4).Value = SCll.Offset(0, 6).Value
        .Offset(TOfsR, 2).Formula = "=A1"
        TOfsR = TOfsR + 1
      End With
    End If
  Next SCll
  Set TCll = Nothing
  Set SCll = Nothing
  Set SBlk = Nothing
End Sub

PS.: Vzhledem k tomu, ze pozadovane procedury jsou na jedno brdo, je nacase se pokusit napsat obdobne procedury sam, jinak vskutku budes s kazdou malickosti chodit na poradnu, tim nechci rict, ze se nemas ptat vubec.

[Branscombe]

Ahoj, díky moc ... máš samozřejmě pravdu, nebylo by od věci pokusit se napsat si to sám, ale zkoušel jsem předělat první proceduru a jak je vidět tak jsem to dělal moc složitě... :-/

PS: Ani raděj nebudu uvádět jak dlouho jsem to zkoušel předělat - byla by to ostuda