poniedziałek, 31 stycznia 2011

EXCEL VBA - kopiowanie tabeli do nowego arkusza i zmiana nazwy zakładki

Makro kopiuje tabele zawierającą dane z arkusza, otwiera plik "archiwum" tworzy tam zakładkę, wkleja dane i zmienia nazwę na podstawie jednej komórki z tej listy. Makro jest w pliku "DANE.xls"


Sub archiwum() 
Dim nazwa As String
' określenie komórki w której będzie nazwa nowej zakładki
nazwa = Cells(3, 1)
' kopiujemy dane które zawierają jakieś wartości
    Selection.CurrentRegion.Select
    Selection.Copy
'otwieramy plik "archiwum
   ' Application.WindowState = xlMinimized
        ChDir "C:\\DOKUMENTY"
    Workbooks.Open Filename:="C:\\DOKUMENTY\archiwum.xls"
    Windows("archiwum.xls").Activate
'tworzymy nową zakładkę i wklejamy dane
Sheets.Add
    ActiveSheet.Paste
'układamy kolumny, żeby ładnie wyglądały :)
    Columns("A:A").EntireColumn.AutoFit
        Columns("E:E").EntireColumn.AutoFit
    Columns("G:G").EntireColumn.AutoFit
    Columns("I:I").EntireColumn.AutoFit
    Columns("M:M").EntireColumn.AutoFit
    Range("A3").Select
    Application.CutCopyMode = False
    Selection.Copy
'zmieniamy nazwę zakładki
    Sheets("Arkusz1").Select
    Sheets("Arkusz1").Name = nazwa
' zapisujemy zmiany i zamykamy plik archiwum
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Windows("DANE.xls").Activate
    Range("A3").Select
End Sub

I jeszcze fragment kodu, który zmienia też nazwę zapisywanego pliku.
ActiveWorkbook.SaveAs Filename:= _
     "C:\\DOKUMENTY\plik_" & nazwa & ".xls" _
        , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWorkbook.Close 

EXCEL VBA - generowanie zakładki pod korespondencje seryjną.

EXCEL
Kod filtruje listę (w zakładce "WORK") na podstawie określonych kryteriów i kopiuje do istniejącej zakładki( SERYJNA) (wcześniej ją czyszcząc) wartości, które potem są wykorzystywane do korespondencji seryjnej w wordzie

Sub gen_seryjna()
' wpierw czyścimy zakładkę "SERYJNA"
    Sheets("SERYJNA").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    Sheets("WORK").Select
' filtrujemy, "Field=10" to określenie kolumny, "kryteria" to kryteria filtrowania
    Selection.AutoFilter Field:=10, Criteria1:="OBCIĄŻENIE"
' zaznacza tylko komórki w których istnieją dane  
    Selection.CurrentRegion.Select 
    Selection.Copy
    Rows("1:1").Select
    Sheets("SERYJNA").Select
    Range("A1").Select
' wklejamy 
    ActiveSheet.Paste
' usuwamy pierwszy wiersz (który w moim pliku np zawierał przyciski, a nazwy kolumn były w drugim wierszu) 
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
' kolumny wyrównujemy 
    Columns("A:N").EntireColumn.AutoFit
    Sheets("WORK").Select
    Selection.AutoFilter Field:=10
    Range("A3").Select
    Application.ScreenUpdating = True
End Sub