Stránka 1 z 1
VBA Excel - překopírování doposud nezkopírovaných dat
Napsal: 18 čer 2010 14:58
od 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
Re: VBA Excel - překopírování doposud nezkopírovaných dat
Napsal: 18 čer 2010 16:21
od 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
Re: VBA Excel - překopírování doposud nezkopírovaných dat
Napsal: 21 čer 2010 10:05
od 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"
Re: VBA Excel - překopírování doposud nezkopírovaných dat
Napsal: 21 čer 2010 10:35
od 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)
Re: VBA Excel - překopírování doposud nezkopírovaných dat
Napsal: 21 čer 2010 12:05
od Branscombe
Á jo ... No to jsem taky mohl vymyslet sám ... No nic, díky moc ...
Re: VBA Excel - překopírování doposud nezkopírovaných dat
Napsal: 24 čer 2010 07:34
od 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 :-/
Re: VBA Excel - překopírování doposud nezkopírovaných dat
Napsal: 24 čer 2010 08:55
od 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 SubJe dobre mit jasno v tom, co pozaduji.
Re: VBA Excel - překopírování doposud nezkopírovaných dat
Napsal: 24 čer 2010 13:31
od 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
Re: VBA Excel - překopírování doposud nezkopírovaných dat
Napsal: 24 čer 2010 14:45
od 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
Re: VBA Excel - překopírování doposud nezkopírovaných dat
Napsal: 25 čer 2010 07:37
od Branscombe
Super, funguje ... ještě to pořádně otestuji ...
Re: VBA Excel - překopírování doposud nezkopírovaných dat
Napsal: 02 črc 2010 13:36
od 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)
Re: VBA Excel - překopírování doposud nezkopírovaných dat Vyřešeno
Napsal: 02 črc 2010 17:54
od 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")
...