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