Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 64661 Skopiuj do schowka Łączenie plików
Autor Wiadomość
cezaryfcb89 
Fan Excela


Posty: 76
Wysłany: 05-04-2019, 12:20   Łączenie plików

Heya,
mam problem z makrem którego zadaniem jest łączenie kilku plików które mają arkusz o nazwie Sheet1. Mam pytanie czy da się go zmienić aby zamiast pobierania tylko z jednego arkusza o wybranej nazwie Sheet1 pobierał cały plik

Kod:
Sub Laczenie_plikow()

Dim przedstaw As Variant
Dim DoSkop As Workbook, Docel As Worksheet
Dim ostWiersz As Long, x As Integer
Dim ostDocel As Long, y As Long
Dim k As Long

Application.ScreenUpdating = False

Set Docel = ThisWorkbook.Worksheets("Sheet1")

With Docel

ostDocel = .Cells(.Rows.Count, "A").End(xlUp).Row

If ostDocel > 2 Then
    .Range("A3:F" & ostDocel).ClearContents
End If

End With

przedstaw = Application.GetOpenFilename(fileFilter:="Pliki Excel (*.xls),*.xls,", _
        Title:="Zaznacz wszystkie pliki przedstawicieli", MultiSelect:=True)
       
k = 3
For x = LBound(przedstaw) To UBound(przedstaw)
    Set DoSkop = Workbooks.Open(przedstaw(x))
   
[color=red]    With DoSkop.Worksheets("Sheet1")[/color]
   
    ostWiersz = .Cells(.Rows.Count, "A").End(xlUp).Row
    For y = 1 To ostWiersz
        .Range("A" & y & ":Z" & y).Copy
        Docel.Range("A" & k).PasteSpecial xlPasteValues
        k = k + 1
    Next y
   
    End With
    DoSkop.Close
    Set DoSkop = Nothing

Next x

Set Docel = Nothing

Application.ScreenUpdating = True

    ' Koniec
    Range("A1").Select

End Sub


Kody i formuły zamykaj w znacznikach Kod (Code).
Wyjątkowo poprawiłem.
umiejead

.
ID posta: 365514 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 2647 razy
Posty: 8778
Wysłany: 05-04-2019, 13:36   

Rozumiem, że chodzi o pobranie danych z wszystkich arkuszy zaznaczonych przez użytkownika skoroszytów.
Jeśli tak, to należy w pętli
Kod:
For x = LBound(przedstaw) To UBound(przedstaw)
dodać pętlę, która przeleci się po wszystkich arkuszach roboczych przetwarzanego skoroszytu. Coś w ten deseń:
Kod:
    Dim wks         As Worksheet

    For x = LBound(przedstaw) To UBound(przedstaw)
        Set DoSkop = Workbooks.Open(przedstaw(x))

        For Each wks In DoSkop.Worksheets

            With wks

                ostWiersz = .Cells(.Rows.Count, "A").End(xlUp).Row
                For y = 1 To ostWiersz
                    '.Range("A" & y & ":Z" & y).Copy
                    'Docel.Range("A" & k).PasteSpecial xlPasteValues
                    Docel.Range("A" & k).Resize(, 26).Value = .Range("A" & y & ":Z" & y)
                    k = k + 1
                Next y

            End With

        Next wks

        DoSkop.Close False

    Next x
Zwracam uwagę, że zmieniłem sposób kopiowania danych (samych wartości).

Pętlę można jeszcze przyspieszyć kopiując nie wiersz po wierszu, a całe zakresy:
Kod:
    Dim wks         As Worksheet

    For x = LBound(przedstaw) To UBound(przedstaw)
        Set DoSkop = Workbooks.Open(przedstaw(x))

        For Each wks In DoSkop.Worksheets

            With wks

                ostWiersz = .Cells(.Rows.Count, "A").End(xlUp).Row
               
                Docel.Range("A" & k).Resize(ostWiersz, 26).Value = .Range("A1").Resize(ostWiersz, 26).Value
               
                k = k + ostWiersz
               
            End With

        Next wks

        DoSkop.Close False

    Next x

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 365525 Skopiuj do schowka
 
 
cezaryfcb89 
Fan Excela


Posty: 76
Wysłany: 08-04-2019, 15:06   

Heya, może ktoś wie czy da się przekształcić poniższe makro po kopiowania plików .csv ponieważ po zastosowaniu tego makra dane są w jednej kolumnie A oddzielone ; a w pliku .csv były podzielona A:U.

Kod:
Sub Laczenie_plikow()

Dim przedstaw As Variant
Dim DoSkop As Workbook, Docel As Worksheet
Dim ostWiersz As Long, x As Integer
Dim ostDocel As Long, y As Long
Dim k As Long

Application.ScreenUpdating = False

Set Docel = ThisWorkbook.Worksheets("Sheet1")

With Docel

ostDocel = .Cells(.Rows.Count, "A").End(xlUp).Row

If ostDocel > 2 Then
    .Range("A3:F" & ostDocel).ClearContents
End If

End With

przedstaw = Application.GetOpenFilename(fileFilter:="Pliki Excel (*.),*.csv,", _
        Title:="Zaznacz wszystkie pliki przedstawicieli", MultiSelect:=True)
       
k = 2

    Dim wks         As Worksheet

     For x = LBound(przedstaw) To UBound(przedstaw)
         Set DoSkop = Workbooks.Open(przedstaw(x))

         For Each wks In DoSkop.Worksheets

             With wks

                 ostWiersz = .Cells(.Rows.Count, "A").End(xlUp).Row
                 
                 Docel.Range("A" & k).Resize(ostWiersz, 26).Value = .Range("A1").Resize(ostWiersz, 26).Value
                 
                 k = k + ostWiersz
                 
             End With

         Next wks

         DoSkop.Close False

     Next x

 

    ' Koniec
    Range("A1").Select

End Sub
ID posta: 365640 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 2647 razy
Posty: 8778
Wysłany: 09-04-2019, 00:39   

Proponuję kilkudniowy odpoczynek za niestosowanie się do zaleceń moderatora i nie czytanie regulaminu.
Możesz ten czas wykorzystać na zaznajomienie się z regulaminem, a także z wątkami które wyjaśniają jak obchodzić się z plikami CSV. Zwróć uwagę na otwieranie i importowanie tego typu plików.

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 365663 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe