Excel VBA - kopírování dat

[Branscombe]

Ahoj všem,

potřeboval bych poradit s jedním makrem v Excelu. V příloze je soubor kde potřebuji kopírovat data z listu Temp.
Makro by mělo prohledat celý list Temp od řádku 3 směrem dolů a vložit údaje z buňek C:I do listu který je určen poslední buňkou na řádku.
Na tomto listu (D47) by mělo prohledat řádek 2 a v případě shody hodnoty z řádku 2 s hodnotou z listu Temp z předposledního sloupce vloží kopírované hodnoty do posledního volného řádku (od řádku 10) - 3 sloupce.

Doufám, že jsem to napsal srozumitelně a hlavně že jsem nezapomněl nic definovat ...

[Reklama]

[navstevnik]

Vloz proceduru do standardniho modulu:

Kód: Vybrat vše

Option Explicit

Sub Transfer()
  Dim TmpBlk As Range, TmpCll As Range
  Dim FWsht As Worksheet, FBlk As Range, FCll As Range
  Dim TCll As Range

  ' blok na listu temp K1:Kxx
  With ActiveWorkbook.Worksheets("temp")
    Set TmpBlk = .Range("k1:k" & .Cells(.Rows.Count, 11).End(xlUp).Row)
    If TmpBlk.Rows.Count = 1 Then
      MsgBox "List Temp neobsahuje data"
      GoTo ErrHandler1
    End If
    Set TmpBlk = TmpBlk.Resize(TmpBlk.Rows.Count - 2, 1).Offset(2, 0)
  End With
  ' prochazet blok TmpBlk
  For Each TmpCll In TmpBlk.Cells
    On Error Resume Next
    ' definovat list z TmpCll
    Set FWsht = ActiveWorkbook.Worksheets(TmpCll.Value)
    If Err.Number <> 0 Then
      MsgBox "Nenalezen list:" & TmpCll.Value
      GoTo ErrHandler2
    End If
    With FWsht
      ' na listu FWsht projit radek 2:2
      Set FBlk = .Range("a2:" & .Cells(2, .Columns.Count).End(xlToLeft).Address(0, 0))
      For Each FCll In FBlk.Cells
        ' pri shode najit na listu prvni volny radek ve sloupci A:A
        If FCll.Value = TmpCll.Offset(0, -1).Value Then
          Set TCll = .Range("a" & .Cells(.Rows.Count, 1).End(xlUp).Row)
          If TCll.Row = 1 Then
            Set TCll = TCll.Offset(9, 0)
          Else
            Set TCll = TCll.Offset(1, 0)
          End If
          ' prenest radek z Tmp na Fwsht
          TCll.Resize(1, 7).Value = TmpCll.Resize(1, 7).Offset(0, -8).Value
          Set TCll = Nothing
        End If
      Next FCll
      Set FCll = Nothing
      Set FBlk = Nothing
    End With
  Next TmpCll
  Set FWsht = Nothing
ErrHandler2:
  Set TmpCll = Nothing
ErrHandler1:
  Set TmpBlk = Nothing
End Sub

[Branscombe]

Díky, ale nefunguje to jak by mělo :-/
1. Makro by mělo vyhledat hodnotu z listu Temp, z předposledního sloupce (např. 0123 ABC - ABC) - (ne vždy to bude ten samý sloupec, ale vždy bude předposlední) na listu definovaném posledním sloupcem řádku (D47), nikoliv na přímo ze sloupce K, jelikož někdy to může být sloupec L atd... (ale vždy to bude poslední hodnota na řádku)
2. Na listu D47 prohledá řádek 2 a v případě shody s hodnotou z předposledního sloupce z listu Temp vloží na poslední volný řádek daného sloupce kde se nachází shodná hodnota mínus 3 sloupce, takže další tři řádky budou vypadat viz příloha ...

Doufám že teď je to již srozumitelné ...

[navstevnik]

Kód: Vybrat vše

Option Explicit

Sub Transfer()
  Dim TmpBlk As Range, TmpCll As Range, LstCll As Range
  Dim FWsht As Worksheet, FBlk As Range, FCll As Range
  Dim TCll As Range

  ' blok na listu temp c1:cxx
  With ActiveWorkbook.Worksheets("temp")
    Set TmpBlk = .Range("c1:c" & .Cells(.Rows.Count, 3).End(xlUp).Row)
    If TmpBlk.Rows.Count = 2 Then
      MsgBox "List Temp neobsahuje data"
      GoTo ErrHandler1
    End If
    Set TmpBlk = TmpBlk.Resize(TmpBlk.Rows.Count - 2, 1).Offset(2, 0)
  End With
  ' prochazet blok TmpBlk
  For Each TmpCll In TmpBlk.Cells
    With TmpCll
      Set LstCll = .Offset(0, .End(xlToRight).Column - 3)
    End With
    On Error Resume Next
    ' definovat list z LstCll
    Set FWsht = ActiveWorkbook.Worksheets(LstCll.Value)
    If Err.Number <> 0 Then
      MsgBox "Nenalezen list:" & LstCll.Value
      GoTo ErrHandler2
    End If
    With FWsht
      ' na listu FWsht projit radek 2:2
      Set FBlk = .Range("a2:" & .Cells(2, .Columns.Count).End(xlToLeft).Address(0, 0))
      For Each FCll In FBlk.Cells
        ' pri shode najit na listu prvni volny radek ve sloupci shody-3 pocinaje radkem 10
        If FCll.Value = LstCll.Offset(0, -1).Value Then
          Set TCll = FCll.Offset(.Rows.Count - 2, -3)
          If TCll.End(xlUp).Row = 1 Then
            Set TCll = FCll.Offset(8, -3)
          Else
            Set TCll = TCll.End(xlUp).Offset(1, 0)
          End If
          ' prenest radek z Tmp na Fwsht
          TCll.Resize(1, 7).Value = TmpCll.Resize(1, 7).Value
          Set TCll = Nothing
        End If
      Next FCll
      Set FCll = Nothing
      Set FBlk = Nothing
    End With
ErrHandler2:
    Set LstCll = Nothing
  Next TmpCll
  Set FWsht = Nothing
  Set TmpCll = Nothing
ErrHandler1:
  Set TmpBlk = Nothing
End Sub

[Branscombe]

Ahoj díky moc, kde jsi se to naučil ?? Živíš se tím ??

Zkoušel jsem makro které jsi mi napsal to a fungovalo to, ale pak jsem přidal data a z nějakého mě neznámého důvodu to nekopíruje data na 10 řádek, ale na osmý. Procházel jsem proceduru a na nic jsem nepřišel ... :-/

Pak jsem si taky objevil chybu v zadání, jelikož jsem psal "a vložit údaje z buňek C:I" a mělo by to být "a vložit údaje z buňek C:předpředposlední sloupec", jelikož poslední určuje list a předposlední určuje sadu v řádku 2.

Tak kdybych mohl poprosit jestli by ses mi na to podíval ... Předem díky moc ...

[navstevnik]

Doplnena procedura - ruzny pocet polozek v zaznamu:

Kód: Vybrat vše

Option Explicit

Sub Transfer()
  Dim TmpBlk As Range, TmpCll As Range, LstCll As Range
  Dim FWsht As Worksheet, FBlk As Range, FCll As Range
  Dim TCll As Range, TOffsCol As Integer

  ' blok na listu temp c1:cxx
  With ActiveWorkbook.Worksheets("temp")
    Set TmpBlk = .Range("c1:c" & .Cells(.Rows.Count, 3).End(xlUp).Row)
    If TmpBlk.Rows.Count = 2 Then
      MsgBox "List Temp neobsahuje data"
      GoTo ErrHandler1
    End If
    Set TmpBlk = TmpBlk.Resize(TmpBlk.Rows.Count - 2, 1).Offset(2, 0)
  End With
  ' prochazet blok TmpBlk
  For Each TmpCll In TmpBlk.Cells
    With TmpCll
      Set LstCll = .Offset(0, .End(xlToRight).Column - 3)
      TOffsCol = LstCll.Column - .Column - 1
    End With
    On Error Resume Next
    ' definovat list z LstCll
    Set FWsht = ActiveWorkbook.Worksheets(LstCll.Value)
    If Err.Number <> 0 Then
      MsgBox "Nenalezen list:" & LstCll.Value
      GoTo ErrHandler2
    End If
    With FWsht
      ' na listu FWsht projit radek 2:2
      Set FBlk = .Range("a2:" & .Cells(2, .Columns.Count).End(xlToLeft).Address(0, 0))
      For Each FCll In FBlk.Cells
        ' pri shode najit na listu prvni volny radek ve sloupci shody-3 pocinaje radkem 10
        If FCll.Value = LstCll.Offset(0, -1).Value Then
          Set TCll = FCll.Offset(.Rows.Count - 2, -3)
          If TCll.End(xlUp).Row = 1 Then
            Set TCll = FCll.Offset(8, -3)
          Else
            Set TCll = TCll.End(xlUp).Offset(1, 0)
          End If
          ' prenest radek z Tmp na Fwsht
          TCll.Resize(1, TOffsCol).Value = TmpCll.Resize(1, TOffsCol).Value
          Set TCll = Nothing
        End If
      Next FCll
      Set FCll = Nothing
      Set FBlk = Nothing
    End With
ErrHandler2:
    Set LstCll = Nothing
  Next TmpCll
  Set FWsht = Nothing
  Set TmpCll = Nothing
ErrHandler1:
  Set TmpBlk = Nothing
End Sub

Co se tyce transferu na radek 8 misto 10, tak to je bohuzel dusledek drive ulozenych a pozdeji odstranenych hodnot v bunkach, ale Excelovsky sesit si to vnitrne pamatuje a vraci jejich adresu, zkratka stanka nebyla panensky prazdna, takze je chybne nalezen prvni volny radek ve sloupci.
V ukazce vzor.xlxm, kterou jsi prilozil, vyber bunku D47!O1 a stiskni Ctrl+sipka dolu. Misto presunu vyberu na bunku O8, kde je transferem vlozena hodnota, je vybrana bunka O4 (a dokud nebyla transferovana data, tak nasledne O7). Naprava: odstran sloupec O (taktez V) a vloz sloupec nebo nepouzivej, receno s nadsazkou, "pocmarany" list. Vysledek bude OK.

[Branscombe]

Super, díky moc za pomoc ... Ještě chvíli budu testovat a pak téma uzavřu ... Ještě jednou díky ...

[Branscombe]

Pouze dotaz - napadá někoho jak nejrychleji a nejlépe od sebe oddělit textový řetězec do jednotlivých buňek ??

Mám text ve formátu "123; 1651; 15; 165146; 17; 1;178 ; asdfasd ; askhd"
A potřeboval bych vždy do jedné buňky oddělit nejdříve text před prvním středníkem, pak mezi prvním a druhým středníkem, pak mezi druhým a třetím středníkem atd... Napadá někoho něco lepšího než je "PROČISTIT(ČÁST($A1;NAJÍT(";";A1;NAJÍT(";";A1;NAJÍT(";";A1;NAJÍT(";";A1;NAJÍT(";";A1;1)+1)+1)+1)+1)+1;NAJÍT(";";A1;NAJÍT(";";A1;NAJÍT(";";A1;NAJÍT(";";A1;NAJÍT(";";A1;NAJÍT(";";A1;1)+1)+1)+1)+1)+1)-NAJÍT(";";A1;NAJÍT(";";A1;NAJÍT(";";A1;NAJÍT(";";A1;NAJÍT(";";A1;1)+1)+1)+1)+1)-1))" atd... ??

[navstevnik]

Hm, jiz od velmi starych verzi Excelu je k dispozici funkcionalita Text do sloupcu. V Excelu 2007: Data>Datove nastroje>Text do sloupcu a dal podle Pruvodce prevodem textu do sloupcu.
V procedure VBA muzes pouzit napr.:

Kód: Vybrat vše

    Worksheets("list1").Range("a1:a10").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1))

[Branscombe]

Á jo ... No jo ... To byl ale zbytečný dotaz ... :-/

Díky moc, prostě jsem na to zpomněl

--- Doplnění předchozího příspěvku (01 Pro 2010 14:28) ---

Měl bych podobný, ale přesto rozdílný problém. Zkoušel jsem si proceduru napasovat na další podobné zadání, ale zasekl jsem se

Potřeboval bych překopírovat data z listu temp řádek po řádku na list určený poslední buňkou v řádku.
Překopírovat data tak že: vyhledá hodnotu ze sloupce C list Temp na listu určeném poslední buňkou (dále jen D47) ve sloupci D a v případě shody této hodnoty ověří ještě shodu prvních dvou buněk (Temp A:B = D47 B:C) - v případě celkové shody vloží jednotlivá data ze sloupců do sloupců na listu D47 přičemž vždy prohledá první řádek, tak aby když je na listu Temp označen sloupec v prvním řádku "číslo 6", aby vyhledal v prvním řádku na listu D47 sloupec "číslo 6".
Pakliže nenajde číslo 2 ze sloupce C list Temp na listu D47 ve sloupci D, založí nový záznam což znamená překopíruje buňky z A:B Temp do D47 B:C
Pakliže najde číslo 2 ze sloupce C list Temp na listu D47 ve sloupci D, ale Temp A:B se nerovná D47 B:C, nedělá nic a přejde k dalšímu záznamu ...

Ve vzorovém příkladu jsou dva listy Temp, jelikož na list Temp budu nejdříve exportovat data z jiných souborů, ale vždy do "Temp" takže abych naznačil jiná data...

Doufám že jsem to napsal alespoň trochu srozumitelně ... :-/

[navstevnik]

Zkus jeste jednou a srozumitelne napsat co potrebujes.
Potřeboval bych překopírovat data z listu temp řádek po řádku na list určený poslední buňkou v řádku.
Překopírovat data tak že: vyhledá hodnotu ze sloupce C list Temp ?vzhledem k nasledujicimu zrejme se jedna o list Temp2? na listu určeném poslední buňkou (dále jen D47) ve sloupci D ? To znamena, ze na listu D47 jsou jiz odnekud nakopirovana data podle nejakeho algoritmu? Nejspis asi z listu ozanceneho Temp? a v případě shody této hodnoty ověří ještě shodu prvních dvou buněk (Temp A:B = D47 B:C) ?Na listu temp2? - v případě celkové shody vloží jednotlivá data ze sloupců do sloupců na listu D47 ? nejspis sloupce cislo 7, 8, 9 listu Temp2 na list D47 shodne oznacene sloupce? přičemž vždy prohledá první řádek, tak aby když je na listu Temp označen sloupec v prvním řádku "číslo 6", aby vyhledal v prvním řádku na listu D47 sloupec "číslo 6". ?tak tomu nerozumim, co je mineno: '...listu Temp označen sloupec v prvním řádku "číslo 6", aby vyhledal v prvním řádku na listu D47 sloupec "číslo 6" '? list Temp2?, jak oznacen, jak ho programove identifikovat, notabene v prvnim radku Temp2 zadny sloupec majici hlavicky "cislo 6" neni a co s tim po vyhledani dal udelat?
Pakliže nenajde číslo 2 ze sloupce C list Temp na listu D47 ve sloupci D, založí nový záznam což znamená překopíruje buňky z A:B Temp do D47 B:C
Pakliže najde číslo 2 ze sloupce C list Temp na listu D47 ve sloupci D, ale Temp A:B se nerovná D47 B:C ?a co kdyz se rovna? , nedělá nic a přejde k dalšímu záznamu ...
A to pochybuji, ze se mi podarilo tuto logickou saradu zcela pochopit.
Vypada to tak, ze cela ta aplikace, z niz predkladas jednotlive kousky, je jeden velky propletenec, na jehoz projiti by bylo potreba Ariadninu nit.

[Branscombe]

Zkusím to napsat srozumitelněji.

Na list Temp kopíruji data z jiných souborů a z listu Temp potřebuji kopírovat data na další listy. Tyto další listy jsou určeny vždy poslední buňkou v řádku.
Procedura by měla pracovat řádek po řádku od shora.

Pro první řádek záznamu:
1. Hodnotu z buňky Temp!C3 vyhledá v D47!D:D (nalezený řádek), hodnotu z Temp!D1 vyhledá v prvním řádku listu D47 (nalezený sloupec), v případě shody kopíruje Temp!D3 do nalezeného řádku a sloupce. V případě že nanajde řádek, založí nový záznam na listu D47, tak že nakopíruje Temp!A3:C3 do D47!B"poslední radek":D"posledni radek". V případě že nenajde sloupec, nakopíruje Temp!D1 do D47!první řádek/poslední sloupec a do tohoto sloupce na příslušný řádek vloží data.

Podmínka po nalezení řádku se záznamem - ověří zda-li Temp!A3:B3 = D47!B:C na nalezeném řádku - když se rovná, pokračuje dále - kopíruje data, když se nerovná - nic nekopíruje a přejde na další záznam.

Doufám že je to nyní srozumitelnějsí a na nic jsem nezapomněl - pro lepší názornost ještě přikládám obrázek.