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
VBA Excel - překopírování doposud nezkopírovaných dat Vyřešeno
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
VBA Excel - překopírování doposud nezkopírovaných dat
- Přílohy
-
- x.zip
- (11.66 KiB) Staženo 20 x
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - překopírování doposud nezkopírovaných dat
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):
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
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - překopírování doposud nezkopírovaných dat
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"
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
- Master Level 7.5
- Příspěvky: 5860
- Registrován: srpen 07
- Bydliště: Pardubice
- Pohlaví:
- Stav:
Offline
- Kontakt:
Re: VBA Excel - překopírování doposud nezkopírovaných dat
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)
Nejlepší hra je Excel!
• Pravidla fóra PC-help • Jak označit téma za vyřešené
»»»»»»»»»»»»»»»»»»»»»»»
UPOZORNĚNÍ - můj Skype, Soukromé zprávy či email neslouží jako tech. podpora.
Dotazy pište do fóra. Od toho tu je.
• Pravidla fóra PC-help • Jak označit téma za vyřešené
»»»»»»»»»»»»»»»»»»»»»»»
UPOZORNĚNÍ - můj Skype, Soukromé zprávy či email neslouží jako tech. podpora.
Dotazy pište do fóra. Od toho tu je.
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - překopírování doposud nezkopírovaných dat
Á jo ... No to jsem taky mohl vymyslet sám ... No nic, díky moc ...
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - překopírování doposud nezkopírovaných dat
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 :-/
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 :-/
- Přílohy
-
- x.zip
- (18.28 KiB) Staženo 15 x
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - překopírování doposud nezkopírovaných dat
Procedura, kterou jsem uvedl presne splnuje zadany pozdavek z 18.6 a odpovida prilozenym souborum:
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.
Je dobre mit jasno v tom, co pozaduji.
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
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - překopírování doposud nezkopírovaných dat
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
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
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - překopírování doposud nezkopírovaných dat
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
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - překopírování doposud nezkopírovaných dat
Super, funguje ... ještě to pořádně otestuji ...
- Branscombe
- Level 3
- Příspěvky: 469
- Registrován: červen 09
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - překopírování doposud nezkopírovaných dat
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 ??
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)
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: VBA Excel - překopírování doposud nezkopírovaných dat Vyřešeno
Proc ti to nebezi na terminalech (???) neporadim.
Jen k tve uprave, mela by vypadat takto:
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")
...
-
- Mohlo by vás zajímat
- Odpovědi
- Zobrazení
- Poslední příspěvek
-
- 16
- 6697
-
od mirekol
Zobrazit poslední příspěvek
20 říj 2023 08:31
-
-
Excel komparacedvou soborů Příloha(y)
od teichmann.ondrej » 15 dub 2024 17:26 » v Kancelářské balíky - 11
- 3488
-
od teichmann.ondrej
Zobrazit poslední příspěvek
22 dub 2024 15:45
-
-
- 1
- 610
-
od Grimm
Zobrazit poslední příspěvek
12 bře 2024 21:43
-
- 3
- 2212
-
od Story-Long
Zobrazit poslední příspěvek
14 srp 2023 10:11
-
- 5
- 2764
-
od mmmartin
Zobrazit poslední příspěvek
13 črc 2023 18:44
Kdo je online
Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 5 hostů