VBATools

Kopiowanie przyrostowe danych z innych skoroszytów

by on Feb.16, 2012, under Excel, Porady

Kopiowanie przyrostowe często wpędza w zakłopotanie. Jak wykonać działanie szybko i bez konieczności szukania, zaznaczania zakresów, przechodzenia pomiędzy skoroszytami etc.

Poniżej przedstawiam drobny kod, który pokazuje jak otworzyć plik, zadeklarować obszar, odnaleźć w docelowym arkuszu ostatnią wypełnioną komórkę i do następnej import danych z zakresu pliku źródłowego. Zakładamy w nim iż plik źródłowy ma jeden lub pierwszy arkusz z danymi jakie nas interesują. Drugim założeniem jest iż kopiujemy wszystkie dane z zakresu kolumny A (może być zakres wielu kolumn).

Sub open_copy_paste_n_close()
'MVP OShon from VBATools.pl
Const nazwapliku$ = "c:\Temp\1.xlsx" 'Nazwa pliku do otwarcia
Dim thiswkb As Workbook, wkb As Workbook, min_row&
Set thiswkb = ActiveWorkbook
Call BlockEvScreenCalc(False, "Import danych...")
 Workbooks.Open Filename:=nazwapliku
Set wkb = ActiveWorkbook

Dim rng1 As Range, rng2 As Range
With wkb.Sheets(1)
 Set rng1 = .Range("a1:a" & .Cells(Rows.Count, "a").End(xlUp).Row)
End With
With thiswkb.Sheets("Arkusz1") 'arkusz docelowy
 min_row = .Cells(Rows.Count, "a").End(xlUp).Row
 If Len(.Range("a1")) > 0 Then min_row = min_row + 1 'jeśli mamy nagłówek
 Set rng2 = .Range("a" & min_row)
End With
rng1.Copy rng2
koniec:
On Error Resume Next
wkb.Close False
Set rng1 = Nothing
Set rng2 = Nothing
Set thiswkb = Nothing
Set wkb = Nothing
Call BlockEvScreenCalc(True) 
Exit Sub
blad:
Call BlockEvScreenCalc(True)
 MsgBox "Error: " & Err.Number & vbCr & Err.Description, vbCritical, "VBATools.pl"
Resume koniec
End Sub

Public Sub BlockEvScreenCalc(Optional ByVal bWlacz As Boolean, Optional Status As String)
 On Error Resume Next
 With Application
 If bWlacz Then
 .EnableEvents = True
 .Calculation = xlCalculationAutomatic
 .StatusBar = ""
 .ScreenUpdating = True
 .Cursor = xlDefault
 Else
 .ScreenUpdating = False
 .Calculation = xlCalculationManual
 .EnableEvents = False
 .StatusBar = Status
 .Cursor = xlWait
 End If
 End With
End Sub

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.

:, , , , ,

Leave a Reply

Recently Active Members

Profile picture of vbatools
Profile picture of Karol Stilger
Profile picture of marcinmachalowski
Profile picture of Joanna Subik
Profile picture of Anorak
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała