VBA Excel - překopírování doposud nezkopírovaných dat Vyřešeno

[Branscombe]

Ahoj, mám opět malinký problém.

Mám soubor kam se průběžně zapisují data a při každém zápisu je do sloupce "E" zapsáno pořadové číslo.

Mám druhý soubor do kterého se z prvního kopírují data. Potřebuji makro které mi zkopíruje jen dosud ještě nezkopírovaná data.

Takže si někam do druhého souboru zapíšu naposledy zkopírované pořadové číslo ("H1") a makru potřebuji říct, zkopíruj data ze souboru "x.xlsm" list "a" od pořadového posledního zkopírovaného pořadového čísla + jedna až do posledního zápisu do druhého souboru "xx.xlsm" na list "aa" a přepiš naposledy zkopírované pořadové číslo v buňce H1 na hodnotu ze sloupce E posledního řádku

Takže v přiložených souborech překopíruje řádky 12:23 (nebo buňky "A12:E23") ze souboru "x.xlsm" z listu "a" do souboru "xx.xlsm" na list "aa" a vloží je na první volný řádek nalezený odspodu listu. Nakonec přepíše buňku "H1" z 10 na 22.

Díky předem za rady

[Reklama]

[navstevnik]

Prilozenou proceduru umisti do standardniho modulu v sesitu xx.xlsm, pripadne pridej klavesovou zkratku pro volani, uprav cestu ke zdroji v radku, otestuj; prepoklad prubezneho a souvisleho cislovani zaznamu:
Set Wbk =Workbooks(...\x.xlsm):

Kód: Vybrat vše

Option Explicit

Sub CopyRecords()
  Dim SWbk As Workbook, SWsht As Worksheet, SBlk As Range
  Dim SLstRecNr As Long
  Dim TWsht As Worksheet, RecNr As Long
  ' cilovy list, posledni zaznam
  Set TWsht = ActiveWorkbook.Worksheets("aa")
  RecNr = TWsht.Range("h1").Value
  ' otevrit zdrojovy sesit a list
  On Error Resume Next
  Set SWbk = Workbooks.Open("E:\Excel\Bransc\x.xls")
  Set SWsht = SWbk.Worksheets("a")
  If Err.Number <> 0 Then
    MsgBox "nenalezen zdrojovy soubor nebo list"
    GoTo ErrHandler
  End If
  On Error GoTo 0
  Set SBlk = SWsht.Range("a1")
  SLstRecNr = SWsht.Cells(Rows.Count, "e").End(xlUp).Value  ' posledni zaznam ve zdroji
  If RecNr < SLstRecNr Then
    ' prenest blok zaznamu ze zdroje
    Set SBlk = SBlk.Resize(SLstRecNr - RecNr, 5).Offset(RecNr + 1, 0)
    TWsht.Range(SBlk.Address).Value = SBlk.Value
    ' ulozit por cislo posledniho zaznamu
    TWsht.Range("h1").Value = SLstRecNr
    Set SBlk = Nothing
  Else
    MsgBox "nejsou nove zaznamy"
  End If
ErrHandler:
  SWbk.Close
  Set SWsht = Nothing
  Set SWbk = Nothing
  Set TWsht = Nothing
End Sub


[Branscombe]

Super, zatím funguje jak má, ale ještě to více prozkouším ...

Jen malá otázečka: Jak upravit tento zápis "Selection.AutoFill Destination:=Range("O2:O1000"), Type:=xlFillSeries" tak aby místo "O1000" byl poslední zaplněný řádek nalezený odspodu listu hledaný ve sloupci "A"

[mike007]

Kód: Vybrat vše

Dim posledni_radek As Long
posledni_radek = Cells(Rows.Count, "A").End(xlUp).Row
Range("O2").AutoFill Destination:=Range("O2:O" & posledni_radek)

[Branscombe]

Á jo ... No to jsem taky mohl vymyslet sám ... No nic, díky moc ...

[Branscombe]

Tak mi to trošku nefunguje.

Když budu mít prvních pár řádků volných a pořadové číslo bude uprostřed textu začínat znovu od jedné tak to nějak moc nefunguje, viz příloha.

Nevím proč se vždycky pořadová čísla přepíšou :-/

[navstevnik]

Procedura, kterou jsem uvedl presne splnuje zadany pozdavek z 18.6 a odpovida prilozenym souborum:

Takže v přiložených souborech překopíruje řádky 12:23 (nebo buňky "A12:E23") ze souboru "x.xlsm" z listu "a" do souboru "xx.xlsm" na list "aa" a vloží je na první volný řádek nalezený odspodu listu. Nakonec přepíše buňku "H1" z 10 na 22.

Nyni prichazis s tim, ze na listu aa v xx.xlsm jsou na zacatku volne radky, ze poradove cislo uprostred textu (??) zacina znovu od jedne, coz puvodne nebylo uvedeno. Predpokladam, ze poradova cisla na listu a v x.xlsm jsou nadale spojite rostouci, jak je v nove priloze.
Takze nize je upravena procedura, ktera vlozi dosud neprenesene zaznamy na cilovy list pocinaje prvnim volnym radkem bez ohledu na to, co je na predchazejicich radcich (pouze dle udaje z H1). Prepoklad je, ze posledni neprazdny radek na cilovem listu ma v bunce A hodnotu.

Kód: Vybrat vše

Option Explicit

Sub CopyRecords()
  Dim SWbk As Workbook, SWsht As Worksheet, SBlk As Range
  Dim SLstRecNr As Long
  Dim TWsht As Worksheet, RecNr As Long, TLstRecNr As Long, TBlk As Range
  ' cilovy list, posledni zaznam
  Set TWsht = ActiveWorkbook.Worksheets("aa")
  RecNr = TWsht.Range("h1").Value
  ' otevrit zdrojovy sesit a list
  On Error Resume Next
  Set SWbk = Workbooks.Open("S:\QA\_Shared\Interni vypady\service\x\x.xlsm")
  Set SWsht = SWbk.Worksheets("a")
  If Err.Number <> 0 Then
    MsgBox "nenalezen zdrojovy soubor nebo list"
    GoTo ErrHandler
  End If
  On Error GoTo 0
  SLstRecNr = SWsht.Cells(Rows.Count, "e").End(xlUp).Value  ' posledni zaznam ve zdroji
  If RecNr < SLstRecNr Then
    ' prenest blok zaznamu ze zdroje
    Set SBlk = SWsht.Range("a1")
    Set SBlk = SBlk.Resize(SLstRecNr - RecNr, 5).Offset(RecNr + 1, 0)
    Set TBlk = TWsht.Range("a1")
    TLstRecNr = TWsht.Cells(Rows.Count, "a").End(xlUp).Row ' posledni radek v cili
    Set TBlk = TBlk.Resize(SBlk.Rows.Count, SBlk.Columns.Count).Offset(TLstRecNr, 0)
    TBlk.Value = SBlk.Value
    ' ulozit por cislo posledniho zaznamu
    TWsht.Range("h1").Value = SLstRecNr
    Set SBlk = Nothing
  Else
    MsgBox "nejsou nove zaznamy"
  End If
ErrHandler:
  SWbk.Close
  Set SWsht = Nothing
  Set SWbk = Nothing
  Set TWsht = Nothing
End Sub

Je dobre mit jasno v tom, co pozaduji.

[Branscombe]

Super, funguje ... ještě to pořádně otestuji ...

edit: No ještě bych měl takový malý malinkatý dodateček, který nemění zadání jen přidá funkci...
Nově překopírovaná data zkopírovat i na druhý list s názvem třeba "temp" a vložit do buňky A1

// Příspěvky sloučeny.
// Pokud chceš něco dodat a ještě nikdo po tobě nepřispěl, použij tlačítko >> Upravit << a svůj příspěvek doplň. Díky.
//mike007

[navstevnik]

Doplnena procedura viz nize. Na list temp jsou kopirovana data ukladana vzdy pocinaje bunkou A1, predchozi data jsou odstranena.

Kód: Vybrat vše

Sub CopyRecords()
  Dim SWbk As Workbook, SWsht As Worksheet, SBlk As Range
  Dim SLstRecNr As Long
  Dim TWsht As Worksheet, TWshtTemp As Worksheet, TBlk As Range, RecNr As Long, TLstRecNr As Long
  ' cilovy list, posledni zaznam
  With ActiveWorkbook
    Set TWsht = .Worksheets("aa")
    Set TWshtTemp = .Worksheets("temp")
  End With
  RecNr = TWsht.Range("h1").Value
  ' otevrit zdrojovy sesit a list
  On Error Resume Next
  Set SWbk = Workbooks.Open("S:\QA\_Shared\Interni vypady\service\x\x.xlsm")
  Set SWsht = SWbk.Worksheets("a")
  If Err.Number <> 0 Then
    MsgBox "nenalezen zdrojovy soubor nebo list"
    GoTo ErrHandler
  End If
  On Error GoTo 0
  SLstRecNr = SWsht.Cells(Rows.Count, "e").End(xlUp).Value  ' posledni zaznam ve zdroji
  If RecNr < SLstRecNr Then
    ' prenest blok zaznamu ze zdroje
    Set SBlk = SWsht.Range("a1")
    Set SBlk = SBlk.Resize(SLstRecNr - RecNr, 5).Offset(RecNr + 1, 0)
    Set TBlk = TWsht.Range("a1")
    TLstRecNr = TWsht.Cells(Rows.Count, "a").End(xlUp).Row  ' posledni radek v cili
    Set TBlk = TBlk.Resize(SBlk.Rows.Count, 5).Offset(TLstRecNr, 0)
    TBlk.Value = SBlk.Value
    '  list temp vyprazdnit a kopirovat data
    With TWshtTemp
      .Cells.ClearContents
      .Range("a1").Resize(SBlk.Rows.Count, 5).Value = SBlk.Value
    End With
    ' ulozit por cislo posledniho zaznamu
    TWsht.Range("h1").Value = SLstRecNr
    Set SBlk = Nothing
    Set TBlk = Nothing
    Set TWshtTemp = Nothing
  Else
    MsgBox "nejsou nove zaznamy"
  End If
ErrHandler:
  SWbk.Close
  Set SWsht = Nothing
  Set SWbk = Nothing
  Set TWsht = Nothing
End Sub

[Branscombe]

Super, funguje ... ještě to pořádně otestuji ...

[Branscombe]

Ahoj mám malý problém s výše uvedenou procedurou.

Když si nastavím cestu souboru s odkazem na buňku v sešitu, tak mi makro funguje pouze na počítači, ale ne na terminálech. Nevíte někdo co s tím ?? Když cestu napíšu ručně tak vše funguje jak má i na terminálech. Proč nejde nastavit cesta s odkazem na buňku ??

Kód: Vybrat vše

Set Cesta = Worksheets("Source").Range("S1")
Set Plodina = Worksheets("Main").Range("A4")
Set Rok = Worksheets("Main").Range("E4")
' otevrit zdrojovy sesit a list
On Error Resume Next
Set SWbk = Workbooks.Open("" & Cesta & "\" & Plodina & "\" & Rok & ".xlsm", , True)


[navstevnik]

Proc ti to nebezi na terminalech (???) neporadim.
Jen k tve uprave, mela by vypadat takto:

Kód: Vybrat vše

Dim Cesta As String, Plodina  As String, Rok As String ' deklarace promennych
....
Cesta = Worksheets("Source").Range("S1").Value ' Disk a slozky
Plodina = Worksheets("Main").Range("A4").Value
Rok = Worksheets("Main").Range("E4").Value
' otevrit zdrojovy sesit a list
On Error Resume Next
Set SWbk = Workbooks.Open(Cesta & "\" & Plodina & "\" & Rok & ".xlsm")
...