Elektroda.pl
Elektroda.pl
X
Proszę, dodaj wyjątek www.elektroda.pl do Adblock.
Dzięki temu, że oglądasz reklamy, wspierasz portal i użytkowników.

Excel - Kopiowanie kilku zakresów z kilku arkuszy do kilku arkuszy

Alvares83 27 Sty 2013 16:55 1968 2
  • #1 27 Sty 2013 16:55
    Alvares83
    Poziom 9  

    Witam. Napisałem makro (excel 2010) które kopiuje pewien zakres (od A8 do kolumny E ostani zajęty wiersz) do komórki w kolumnie A pierwszy wolny wiersz w arkuszu w innym skoroszycie, problem polega na tym że chciałbym skopiować kilka zakresów (np A8 do kolumny E ostani zajęty wiersz, O8 do kolumny AK ostani zajęty wiersz, AM8 do kolumny BC ostani zajęty wiersz) do odpowiednich komórek (tzn np kolumnę AM do kolumny AM). Mógłym napisać te zakresy ręcznie ale byłoby ich zbyt dużo (chcę kopiować kilka zakresów z kilku arkuszy).
    Kod:

    Code:
    Sub Aktualizacja_Zel()
    

    Dim Ostatni_zajety_wiersz_Zel As Long
    Dim Pierwszy_wolny_wiersz_Leb As Long
    Dim Ostatnia_zajeta_komórka_Zel As Range
    Dim Pierwsza_wolna_komórka_Leb As Range
    Dim plik As Workbook
    Const plikspr     As String = "D:\PlikA.xlsm"

    If Dir(plikspr) <> "" Then

     On Error Resume Next
     Set plik = Workbooks("PlikA.xlsm")
     On Error GoTo 0
        If plik Is Nothing Then Workbooks.Open "D:\PlikA.xlsm"
     
         Ostatni_zajety_wiersz_Zel = Workbooks("PlikA.xlsm").Sheets("Przeroby").Cells(Rows.Count, 1).End(xlUp).Row
         Pierwszy_wolny_wiersz_Leb = Workbooks("Przeroby, wysylki, stany mag 2013.xlsm").Sheets("Przeroby"). _
         Cells(Rows.Count, 1).End(xlUp).Row + 1
         
         Set Ostatnia_zajeta_komórka_Zel = Cells(Ostatni_zajety_wiersz_Zel, 5)
         Set Pierwsza_wolna_komórka_Leb = Cells(Pierwszy_wolny_wiersz_Leb, 1)
         MsgBox Prompt:="Ostatnia zajęta komórka Zel to " & Ostatnia_zajeta_komórka_Zel.Address & Chr(13) & _
         "Pierwsza wolna komórka Leb to " & Pierwsza_wolna_komórka_Leb.Address, Title:="first free cell"
           
        Workbooks("PlikA.xlsm").Sheets("Przeroby").Range(Cells(8, 1), Ostatnia_zajeta_komórka_Zel).Copy
        Workbooks("Przeroby, wysylki, stany mag 2013.xlsm").Sheets("Przeroby").Cells(Pierwszy_wolny_wiersz_Leb, 1) _
        .PasteSpecial Paste:=xlPasteValues
       
        Workbooks("PlikA").Close SaveChanges:=True
           
    Else
     MsgBox "Brak pliku z Zel"
    End If

    End Sub

    "Zabezpieczyłem" się w razie braku pliku z którego ma pobierać dane oraz w przypadku gdy plik jest już otwarty (nie wiem czy w dobry sposób).
    Próbowałem przy pomocy Split ale działało tylko w przypadku stałych zakresów.
    Ma ktoś pomysł jak to zrobić?

    0 2
  • #2 30 Sty 2013 19:22
    Alvares83
    Poziom 9  

    Wstępnie sobie poradziłem:

    Code:
    Option Explicit
    
    Sub Aktualizacja_Zel()

    Dim Ostatni_zajety_wiersz_Zel_przeroby As Long
    Dim Ostatni_zajety_wiersz_Zel_swiadectwa As Long
    Dim Ostatni_zajety_wiersz_Zel_wysylki As Long
    Dim Pierwszy_wolny_wiersz_Leb_przeroby As Long
    Dim Pierwszy_wolny_wiersz_Leb_swiadectwa As Long
    Dim Pierwszy_wolny_wiersz_Leb_wysylki As Long
    Dim Ostatnia_zajeta_komórka_Zel_przeroby As Range
    Dim Ostatnia_zajeta_komórka_Zel_swiadectwa As Range
    Dim Ostatnia_zajeta_komórka_Zel_wysylki As Range
    Dim Pierwsza_wolna_komórka_Leb_przeroby As Range
    Dim Pierwsza_wolna_komórka_Leb_swiadectwa As Range
    Dim Pierwsza_wolna_komórka_Leb_wysylki As Range
    Dim plikzel As Object
    Dim plikleb As Object
    Dim ilosc_wpisow_przeroby As Integer
    Dim ilosc_wpisow_swiadectwa As Integer
    Dim ilosc_wpisow_wysylki As Integer
    Const lokalizacja As String = "D:\Przeroby Zel.xlsm"

    Set plikleb = Workbooks("Przeroby, wysylki, stany mag 2013 ALI.xlsm")

    If Dir(lokalizacja) <> "" Then

     On Error Resume Next
     Set plikzel = Workbooks("Przeroby Zel.xlsm")
     On Error GoTo 0
     
        If plikzel Is Nothing Then Workbooks.Open lokalizacja
         Set plikzel = Workbooks("Przeroby Zel.xlsm")
         Ostatni_zajety_wiersz_Zel_przeroby = plikzel.Sheets("Przeroby").Cells(Rows.Count, 1).End(xlUp).Row
         Pierwszy_wolny_wiersz_Leb_przeroby = plikleb.Sheets("Przeroby").Cells(Rows.Count, 1).End(xlUp).Row + 1
         
         Set Ostatnia_zajeta_komórka_Zel_przeroby = plikzel.Sheets("Przeroby").Cells(Ostatni_zajety_wiersz_Zel_przeroby, 1)
         Set Pierwsza_wolna_komórka_Leb_przeroby = plikleb.Sheets("Przeroby").Cells(Pierwszy_wolny_wiersz_Leb_przeroby, 1)
           
            If Ostatni_zajety_wiersz_Zel_przeroby > 7 Then
           
                plikzel.Sheets("Przeroby").Activate
                ilosc_wpisow_przeroby = Ostatni_zajety_wiersz_Zel_przeroby - 7
                             
                plikzel.Sheets("Przeroby").Range(Cells(8, "A"), Cells(Ostatni_zajety_wiersz_Zel_przeroby, "E")).Copy
                plikleb.Sheets("Przeroby").Cells(Pierwszy_wolny_wiersz_Leb_przeroby, "A").PasteSpecial Paste:=xlPasteValues




                 
                plikzel.Sheets("Przeroby").Range(Cells(8, "J"), Cells(Ostatni_zajety_wiersz_Zel_przeroby, "M")).Copy
                plikleb.Sheets("Przeroby").Cells(Pierwszy_wolny_wiersz_Leb_przeroby, "J").PasteSpecial Paste:=xlPasteValues
                 
                plikzel.Sheets("Przeroby").Range(Cells(8, "O"), Cells(Ostatni_zajety_wiersz_Zel_przeroby, "AK")).Copy
                plikleb.Sheets("Przeroby").Cells(Pierwszy_wolny_wiersz_Leb_przeroby, "O").PasteSpecial Paste:=xlPasteValues
                 
                plikzel.Sheets("Przeroby").Range(Cells(8, "AM"), Cells(Ostatni_zajety_wiersz_Zel_przeroby, "BF")).Copy
                plikleb.Sheets("Przeroby").Cells(Pierwszy_wolny_wiersz_Leb_przeroby, "AM").PasteSpecial Paste:=xlPasteValues
                 
                plikzel.Sheets("Przeroby").Range(Cells(8, "BH"), Cells(Ostatni_zajety_wiersz_Zel_przeroby, "CB")).Copy
                plikleb.Sheets("Przeroby").Cells(Pierwszy_wolny_wiersz_Leb_przeroby, "BH").PasteSpecial Paste:=xlPasteValues
            Else
                ilosc_wpisow_przeroby = 0
            End If
       
         Ostatni_zajety_wiersz_Zel_swiadectwa = plikzel.Sheets("Świadectwa").Cells(Rows.Count, 3).End(xlUp).Row
         Pierwszy_wolny_wiersz_Leb_swiadectwa = plikleb.Sheets("Świadectwa").Cells(Rows.Count, 3).End(xlUp).Row + 1
         
         Set Ostatnia_zajeta_komórka_Zel_swiadectwa = plikzel.Sheets("Świadectwa").Cells(Ostatni_zajety_wiersz_Zel_swiadectwa, 2)
         Set Pierwsza_wolna_komórka_Leb_swiadectwa = plikleb.Sheets("Świadectwa").Cells(Pierwszy_wolny_wiersz_Leb_swiadectwa, 2)
           
            If Ostatni_zajety_wiersz_Zel_swiadectwa > 5 Then
           
                plikzel.Sheets("Świadectwa").Activate
                ilosc_wpisow_swiadectwa = Ostatni_zajety_wiersz_Zel_swiadectwa - 5
               
                plikzel.Sheets("Świadectwa").Range(Cells(6, "B"), Cells(Ostatni_zajety_wiersz_Zel_swiadectwa, "K")).Copy _
                plikleb.Sheets("Świadectwa").Cells(Pierwszy_wolny_wiersz_Leb_swiadectwa, "B")
               
            Else
           
                ilosc_wpisow_swiadectwa = 0
               
            End If
           
         Ostatni_zajety_wiersz_Zel_wysylki = plikzel.Sheets("Wysyłki").Cells(Rows.Count, 2).End(xlUp).Row
         Pierwszy_wolny_wiersz_Leb_wysylki = plikleb.Sheets("Wysyłki").Cells(Rows.Count, 2).End(xlUp).Row + 1
         
         Set Ostatnia_zajeta_komórka_Zel_wysylki = plikzel.Sheets("Wysyłki").Cells(Ostatni_zajety_wiersz_Zel_wysylki, 2)
         Set Pierwsza_wolna_komórka_Leb_wysylki = plikleb.Sheets("Wysyłki").Cells(Pierwszy_wolny_wiersz_Leb_wysylki, 2)
           
            If Ostatni_zajety_wiersz_Zel_wysylki > 4 Then
           
                plikzel.Sheets("Wysyłki").Activate
                ilosc_wpisow_wysylki = Ostatni_zajety_wiersz_Zel_wysylki - 4
               
                plikzel.Sheets("Wysyłki").Range(Cells(5, "B"), Cells(Ostatni_zajety_wiersz_Zel_wysylki, "D")).Copy
                plikleb.Sheets("Wysyłki").Cells(Pierwszy_wolny_wiersz_Leb_wysylki, "B").PasteSpecial Paste:=xlPasteValues
               
                plikzel.Sheets("Wysyłki").Range(Cells(5, "F"), Cells(Ostatni_zajety_wiersz_Zel_wysylki, "F")).Copy
                plikleb.Sheets("Wysyłki").Cells(Pierwszy_wolny_wiersz_Leb_wysylki, "F").PasteSpecial Paste:=xlPasteValues
               
                plikzel.Sheets("Wysyłki").Range(Cells(5, "I"), Cells(Ostatni_zajety_wiersz_Zel_wysylki, "K")).Copy
                plikleb.Sheets("Wysyłki").Cells(Pierwszy_wolny_wiersz_Leb_wysylki, "I").PasteSpecial Paste:=xlPasteValues
               
                plikzel.Sheets("Wysyłki").Range(Cells(5, "M"), Cells(Ostatni_zajety_wiersz_Zel_wysylki, "N")).Copy
                plikleb.Sheets("Wysyłki").Cells(Pierwszy_wolny_wiersz_Leb_wysylki, "M").PasteSpecial Paste:=xlPasteValues
               
                plikzel.Sheets("Wysyłki").Range(Cells(5, "P"), Cells(Ostatni_zajety_wiersz_Zel_wysylki, "Q")).Copy
                plikleb.Sheets("Wysyłki").Cells(Pierwszy_wolny_wiersz_Leb_wysylki, "P").PasteSpecial Paste:=xlPasteValues
               
                plikzel.Sheets("Wysyłki").Range(Cells(5, "S"), Cells(Ostatni_zajety_wiersz_Zel_wysylki, "S")).Copy
                plikleb.Sheets("Wysyłki").Cells(Pierwszy_wolny_wiersz_Leb_wysylki, "S").PasteSpecial Paste:=xlPasteValues
               
            Else
           
                ilosc_wpisow_wysylki = 0
               
            End If
           
        MsgBox Prompt:="Zaktualizowałem ilości wierszy:" & Chr(13) & ilosc_wpisow_przeroby & " przerobu" _
        & Chr(13) & ilosc_wpisow_swiadectwa & " świadectw" _
        & Chr(13) & ilosc_wpisow_wysylki & " wysyłki.", Title:="Aktualizacja Zel"
       
        ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "\Przeroby Zel " & Date & ".xlsm", FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        ActiveWindow.Close
        Kill lokalizacja
       
    Else

     MsgBox "Brak pliku z Zel"
     
    End If

    End Sub
    W jaki sposób to zoptymalizować?

    0
  • #3 31 Sty 2013 08:19
    grubs
    Poziom 32  

    Spróbuj dać przed kopiowaniem
    application.screenupdating = false
    a na końcu po tych operacjach
    application.screenupdating = true

    0