Excel VBA - kopírování dat

[navstevnik]

To podstatne jsi vsak nepotvrdil: na listu D47 jsou jiz nejaka data (odkud pochazeji neni v teto fazi doplnovani dat podstane) a potrebujes doplnit na list D47 data z listu Temp (v ukazce vsak nazvany Temp2; zrejme z duvodu naznaceni, ze data jiz vlozena na list D47 pochazeji prave z predchoziho obsahu listu Temp a nyni ma list Temp novy obsah = Temp2)?
*****************
Naznacil jsi, ze zde poptavana pomoc ma slouzit k vytvoreni objednavkoveho systemu.
Tak alespon se nesnaz vytvorit objednavkovy system v Excelu, ten neni k tomuto ucelu dost dobre pouzitelny (jak se ukazuje, vznika slozite a tezkopadne monstrum s neustalym komplikovanym presouvanim dat).
Pro tento ucel jsou urceny databazove aplikace (i v Accessu lze vytvorit rozumne reseni) a s prehlednou strukturou (najdi si odpovidajici literaturu) a rozdelujici aplikaci na dve casti FrontEnd, kde opraveneni uzivatele mohou vykonavat stanovene kontrolovane operace s daty (prostrednictvim formularu) a BackEnd, vlastni databaze takto oddelena z duvodu zabezpeceni od primeho pristupu uzivatele (data jsou velmi cenna pro chod firmy).
Pro maly rozsah dat lze takovouto aplikaci vytvorit i v Excelu, ale takto je nutno s navrhem struktury zacit.

[Reklama]

[Branscombe]

Temp2 je pouze pro naznačení dalších možných dat...
Na listu D47 jsou již nějaká data, což jsou data vložena z Temp, tak abych naznačil jak by měla procedura data vložit.

Nevím kdy a čím jsem měl naznačit že to je k vytvoření objednávkového systému - pravděpodobně to bylo nějaké jiné téma. Toto má sloužit k databázi a vyhodnocování měření vyráběných produktů.

[navstevnik]

Netusil jsem, ze mas tak siroky zaber v paralelnim reseni firemnich aplikaci, mel jsem zato, ze resis jednu.

[Branscombe]

Ne ne, řeším toho spousty, jelikož když vidím že spousty lidí dělají několik hodin denně stále se opakující v práci v excelu, tak mi to prostě nedá a snažím se jim trochu ulehčit ...

[navstevnik]

Neshoda datovych typu v Temp1!A:A a D47!B:B, pohlidej si tov jinych pripadech, v procedure osetreno.
Nize uvedena procedura pracuje s listem Temp.

Kód: Vybrat vše

Option Explicit

Sub Transfer()
  Dim TmpBlk As Range, TmpCll As Range, TmpLstCll As Range
  Dim TmpHdrBlk As Range, TmpHdrCll As Range
  Dim FWsht As Worksheet, FBlk As Range, FCll As Range
  Dim FHdrBlk As Range, FHdrCll As Range
  Dim i As Integer, TCll As Range

  ' blok na listu temp d1:dxx
  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)
    Set TmpHdrBlk = .Range("d1:" & .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, -2).Address(0, 0))
  End With
  ' prochazet blok TmpBlk
  For Each TmpCll In TmpBlk.Cells
    ' nalezt posledni bunku na radku
    With TmpCll
      Set TmpLstCll = .Offset(0, .End(xlToRight).Column - 3)
    End With
    On Error Resume Next
    ' definovat list z TmpLstCll
    Set FWsht = ActiveWorkbook.Worksheets(TmpLstCll.Value)
    If Err.Number <> 0 Then
      MsgBox "Nenalezen list:" & TmpLstCll.Value
      GoTo ErrHandler2
    End If
    With FWsht
      ' definovat sloupec D3:Dxx
      Set FBlk = .Range("d1:d" & .Cells(.Rows.Count, 4).End(xlUp).Row)
      If FBlk.Rows.Count <= 2 Then
        MsgBox "List " & FWsht.Name & " neobsahuje data"
        GoTo ErrHandler3
      End If
      Set FBlk = FBlk.Resize(FBlk.Rows.Count - 2, 1).Offset(2, 0)
      ' na listu FWsht projit sloupec D:D, nalezt shodu FCll a TmpCll
      With FBlk
        Set FCll = .Find(TmpCll.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
        If Not FCll Is Nothing Then
          ' pri shode TmpCll a FCll overit shodu TemBlk A:B = FBlk B:C
          If CStr(TmpCll.Offset(0, -1).Value) = CStr(FCll.Offset(0, -1).Value) Then
            If CStr(TmpCll.Offset(0, -2).Value) <> CStr(FCll.Offset(0, -2).Value) Then
              GoTo NoFind
            End If
          Else
            GoTo NoFind
          End If
        Else
          Set FCll = FBlk.Resize(1, 1).Offset(FBlk.Rows.Count, 0)
          FCll.Value = TmpCll.Value
          FCll.Offset(0, -1).Value = TmpCll.Offset(0, -1).Value
          FCll.Offset(0, -2).Value = TmpCll.Offset(0, -2).Value
        End If
        ' overit pritomnost odpovidajici hodnoty z Temp!1:1 na FWsht!1:1
        For Each TmpHdrCll In TmpHdrBlk.Cells
          With FWsht
            Set FHdrBlk = .Range("e1:" & .Cells(1, .Columns.Count).End(xlToLeft).Address(0, 0))
          End With
          With FHdrBlk
            Set FHdrCll = .Find(TmpHdrCll.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
            If FHdrCll Is Nothing Then  ' nenalezeno, doplnit
              Set FHdrCll = FHdrBlk.Resize(1, 1).Offset(0, FHdrBlk.Columns.Count)
              FHdrCll.Value = TmpHdrCll.Value
            End If
            ' a kopirovat hodnotu z Temp!xx:xx na FWsht!yy:yy
            FHdrCll.Offset(FCll.Row - 1, 0).Value = TmpHdrCll.Offset(TmpCll.Row - 1, 0).Value
          End With
          Set FHdrCll = Nothing
          Set FHdrBlk = Nothing
        Next TmpHdrCll
        Set TmpHdrCll = Nothing
      End With
NoFind:
      Set FCll = Nothing
ErrHandler3:
      Set FBlk = Nothing
    End With
ErrHandler2:
    Set TmpLstCll = Nothing
  Next TmpCll
  Set FWsht = Nothing
  Set TmpCll = Nothing
  Set TmpHdrBlk = Nothing
ErrHandler1:
  Set TmpBlk = Nothing
End Sub

otestuj

[Branscombe]

Super, díky moc... Otestuji to a kdyžtak se ozvu ...

EDIT:
Smazal jsem si podmínky když je list prázdný aby stejně nakopíroval data, jelikož ty tam jsou nepotřebné, ale narazil jsem na první problémek. Potřebuji aby překopíroval hodnoty ze všech sloupců listu Temp od sloupce D až do předposledního sloupce, jelikož poslední určuje list na který se kopírují. Současná procedura kopíruje data pouze ze sloupce "D" ... :-/

Možná jsem to špatně specifikoval ikdyž v obrázku to je ...

[navstevnik]

v 8:38 jsem se ptal:

To podstatne jsi vsak nepotvrdil: na listu D47 jsou jiz nejaka data (odkud pochazeji neni v teto fazi doplnovani dat podstane) a potrebujes doplnit na list D47 data z listu Temp (v ukazce vsak nazvany Temp2; zrejme z duvodu naznaceni, ze data jiz vlozena na list D47 pochazeji prave z predchoziho obsahu listu Temp a nyni ma list Temp novy obsah = Temp2)?

a dostal jsem neprilis urcitou odpoved:

Temp2 je pouze pro naznačení dalších možných dat...
Na listu D47 jsou již nějaká data, což jsou data vložena z Temp, tak abych naznačil jak by měla procedura data vložit.

.??

Možná jsem to špatně specifikoval ikdyž v obrázku to je ...

tak bohuzel oboje nepresne, zavadejici, rozporuplne a matouci.

Na zminovanem obrazku (ze 7:28) jsou zobrazeny list D47 a list Temp. V zobrazeni listu Temp je zobrazen pouze obsah listu Tem2 ze souboru vzor.xlsm (tedy jak uvadis zdroj dalsich moznych dat); zadna data odpovidajici listu Temp ze souboru vzor.xlsm (sloupce D:G) nejsou obsazena, pouze data na list D47 do sloupcu I:K. Na listu D47 jako vysledek u radku 9:11 ve sloupcich E:H jsou navic prazdne bunky.
Otazka tedy zni: odkud je vycarovat?

[Branscombe]

Asi jsem dost dobře nepochopil tvé dotazy :-/

Po té co procedura vyhledá příslušný řádek (vyhledá hodnotu ze sloupce C listu Temp ve sloupci D na listu D47), vyhledá příslušný sloupec a kopíruje data - tzn. že vyhledá hodnotu z Temp!D1 na prvním řádku listu D47, do příslušného sloupce a předem vyhledaného řádku vloží data. Dále pokračuje ve vyhledání Temp!E1 na prvním řádku listu D47 a do vyhledaného sloupce a řádku na listu D47 vloží data ... tak pokračuje dále a dále sloupec po sloupci až do předposledního sloupce. Po té když dojde k předposlednímu sloupci, pokračuje s dalším záznamem (řádkem) na listu Temp - vyhledá řádek pro buňku určenou číslem 2, vyhledá sloupec, vloží hodnotu, vyhledá další sloupec, vloží hodnotu atd... opět až do předposledního sloupce.
Počet sloupců na listu Temp může být neomezený (tedy maximálně 256 )

Dle obrázku, vyhledá hodnotu z Temp!C3 v D47!D:D, vyhledá hodnotu z Temp!D1 v D47!1:1, vloží hodnotu z Temp!D3 do D47!I3, vyhledá hodnotu z Temp!E1 v D47!1:1, vloží hodnotu z Temp!E3 do D47!J3, vyhledá hodnotu z Temp!F1 v D47!1:1 - hodnotu nenajde, takže vloží hodnotu z Temp!F1 do prvního volného sloupce D47!K1 a vloží hodnotu z Temp!F3 do D47!K3. Po té pokračuje s dalším řádkem (řádek číslo 4 na listu Temp) ...

Doufám, že teď je vše bez jakýchkoliv nejasností

[navstevnik]

Pozadovat jednoznacne a srozumitelne zadani je jako "hrach na stenu hazeti".
Jen tak mimochodem , v Excelu 2007 lze mit na listu 16384 sloupcu.

Kód: Vybrat vše

Option Explicit

Sub Transfer()
  Dim TmpBlk As Range, TmpCll As Range, TmpLstCll As Range
  Dim TmpHdrBlk As Range, TmpHdrCll As Range, TmpHdrC1 As Variant
  Dim FWsht As Worksheet, FBlk As Range, FCll As Range
  Dim FHdrBlk As Range, FHdrCll As Range
  Dim i As Integer, 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
    TmpHdrC1 = .Range("c1").Value
    Set TmpBlk = TmpBlk.Resize(TmpBlk.Rows.Count - 2, 1).Offset(2, 0)
    Set TmpHdrBlk = .Range("d1:" & .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, -2).Address(0, 0))
  End With
  ' prochazet blok TmpBlk
  For Each TmpCll In TmpBlk.Cells
    ' nalezt posledni bunku na radku
    With TmpCll
      Set TmpLstCll = .Offset(0, .End(xlToRight).Column - 3)
    End With
    On Error Resume Next
    ' definovat list z TmpLstCll
    Set FWsht = ActiveWorkbook.Worksheets(TmpLstCll.Value)
    If Err.Number <> 0 Then
      MsgBox "Nenalezen list:" & TmpLstCll.Value
      GoTo ErrHandler2
    End If
    With FWsht
      ' vlozit hodnotu z temp Ci do Fwsht D1
      .Range("d1").Value = TmpHdrC1
      ' definovat sloupec D3:Dxx
      Set FBlk = .Range("d1:d" & .Cells(.Rows.Count, 4).End(xlUp).Row)
      If FBlk.Rows.Count <= 2 Then
        Set FBlk = .Range("d2")
      Else
        Set FBlk = FBlk.Resize(FBlk.Rows.Count - 2, 1).Offset(2, 0)
      End If
      ' na listu FWsht projit sloupec D3:Dxx, nalezt shodu FCll a TmpCll
      With FBlk
        Set FCll = .Find(TmpCll.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
        If Not FCll Is Nothing Then
          ' pri shode TmpCll a FCll overit shodu TemBlk A:B = FBlk B:C
          If CStr(TmpCll.Offset(0, -1).Value) = CStr(FCll.Offset(0, -1).Value) Then
            If CStr(TmpCll.Offset(0, -2).Value) <> CStr(FCll.Offset(0, -2).Value) Then
              GoTo Difference
            End If
          Else
            GoTo Difference
          End If
        Else
          Set FCll = FBlk.Resize(1, 1).Offset(FBlk.Rows.Count, 0)  ' prvni volny radek
          FCll.Value = TmpCll.Value
          FCll.Offset(0, -1).Value = TmpCll.Offset(0, -1).Value
          FCll.Offset(0, -2).Value = TmpCll.Offset(0, -2).Value
        End If
        ' overit pritomnost odpovidajici hodnoty z Temp!1:1 na FWsht!1:1
        For Each TmpHdrCll In TmpHdrBlk.Cells
          With FWsht
            Set FHdrBlk = .Range("c1:" & .Cells(1, .Columns.Count).End(xlToLeft).Address(0, 0))
          End With
          With FHdrBlk
            Set FHdrCll = .Find(TmpHdrCll.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
            If FHdrCll Is Nothing Then  ' nenalezeno, doplnit
              Set FHdrCll = FHdrBlk.Resize(1, 1).Offset(0, FHdrBlk.Columns.Count)
              FHdrCll.Value = TmpHdrCll.Value
            End If
            ' a kopirovat hodnotu z Temp!xx:xx na FWsht!yy:yy
            FHdrCll.Offset(FCll.Row - 1, 0).Value = TmpHdrCll.Offset(TmpCll.Row - 1, 0).Value
          End With
          Set FHdrCll = Nothing
          Set FHdrBlk = Nothing
        Next TmpHdrCll
        Set TmpHdrCll = Nothing
      End With
Difference:
      Set FCll = Nothing
      Set FBlk = Nothing
    End With
ErrHandler2:
    Set TmpLstCll = Nothing
  Next TmpCll
  Set FWsht = Nothing
  Set TmpCll = Nothing
  Set TmpHdrBlk = Nothing
ErrHandler1:
  Set TmpBlk = Nothing
End Sub

[Branscombe]

OK, díky moc, zatím to funguje jak má ... ještě budu chvíli testovat.

PS: Jak docílím 16384 sloupců ??

[navstevnik]

PS: Jak docílím 16384 sloupců ??

Pro Excel 2007 nijak, list je proste ma.
Excel 2007 a taktez 2010: velikost listu 1 048 576 řádků a 16 384 sloupců
Dalsi technicke parametry Excelu 2007 zde: http://excelplus.net./excel-specifikace-limity.php

[Branscombe]

Ahoj, jak bych docílil toho aby procedura vkládala data na list již od druhého, nikoliv od třetího řádku ?? Zkoušel jsem si to přepsat, ale nějak to nedělá to co bych chtěl. Jinak zbytek potřebných úprav jsem si přepsal, ale tohle mi prostě nejde... :-/