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: 59775 Skopiuj do schowka kopiowanie kolumn pomiędzy skoroszytami
Autor Wiadomość
cwirek
Forumowicz


Posty: 21
Wysłany: 17-12-2017, 11:20   kopiowanie kolumn pomiędzy skoroszytami

Witam,

Bazując na tym, co znalazłem na forum próbuję napisać makro, dzięki któremu będzie możliwe przekopiowywanie danych z różnych skoroszytów do jednego zbiorczego i dołączanie ich na sam koniec listy. W pierwszym etapie mam zamiar przekopiowywać 4 kolumny, z czasem chciałbym zastosować do tego więcej kolumn oraz użyć filtrowanie na podstawie ze skoroszytu "dane" kolumny F, czyli "ex" (będą 3 typy danych w niej).
Na razie jednak wróćmy do przekopiowywania danych z 4 kolumn. Generalnie makro działa, bo przekopiowuje niestety nie wiem dlaczego nie chce przekopiować w ten sam wiersz (robi teraz kopiowanie tak jakby schodkowe). Czy mógłbym prosić o pomoc gdzie jest błąd?

Oto kod

Kod:
Sub MassUpload(ByVal dane As String, arrColumns)
Dim i As Integer, lastRow As Long, cell As Range
    ReDim Preserve arrColumns(LBound(arrColumns) To UBound(arrColumns) + 1)
    arrColumns(UBound(arrColumns)) = "Month"
    With Worksheets("dane")
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        If lastRow > 2 Then
            For i = LBound(arrColumns) To UBound(arrColumns)
                Set cell = .Range("A1:h1").Find(arrColumns(i), , xlValues, xlWhole, xlByColumns, xlNext)
                If Not cell Is Nothing Then
                    cell.Offset(1).Resize(lastRow - 1).Copy
                    With Worksheets("baza_rls")
                    Set cell = .Range("A1:H1").Find(arrColumns(i), , xlValues, xlWhole, xlByColumns, xlNext)
                        .Cells(Rows.Count, 2).End(xlUp).Offset(1, cell.Column - 2).PasteSpecial xlPasteValues
                    End With
                End If
            Next
        End If
    End With
    Application.CutCopyMode = False
End Sub

Sub test()
    MassUpload "dane", Array("data-ec-name", "Artist", "data-ec-brand", "Data")

End Sub


test2.xlsm
Pobierz Plik ściągnięto 143 raz(y) 27.4 KB

ID posta: 336344 Skopiuj do schowka
 
 
dm 
Excel Expert


Wersja: Win Office 2013
Pomógł: 490 razy
Posty: 1331
Wysłany: 17-12-2017, 12:23   

Czy nie wystarczy takie makro?

Kopia test2-1.xlsm
Pobierz Plik ściągnięto 159 raz(y) 28.57 KB

ID posta: 336349 Skopiuj do schowka
 
 
cwirek
Forumowicz


Posty: 21
Wysłany: 17-12-2017, 17:42   

To makro nie robi tego co chcę. Kolejność kolumn w "dane" nie pokrywa się z kolejnością z "baza_rls".
ID posta: 336364 Skopiuj do schowka
 
 
dm 
Excel Expert


Wersja: Win Office 2013
Pomógł: 490 razy
Posty: 1331
Wysłany: 17-12-2017, 19:38   

A teraz widzę, spróbuj podmienić swoje makro na takie
Kod:
Sub MassUpload(ByVal dane As String, arrColumns)
Dim i As Integer, lastRow As Long, cell As Range
    ReDim Preserve arrColumns(LBound(arrColumns) To UBound(arrColumns) + 1)
    arrColumns(UBound(arrColumns)) = "Month"
    With Worksheets("dane")
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        If lastRow > 2 Then
            For i = LBound(arrColumns) To UBound(arrColumns)
                Set cell = .Range("A1:h1").Find(arrColumns(i), , xlValues, xlWhole, xlByColumns, xlNext)
                If Not cell Is Nothing Then
                    cell.Offset(1).Resize(lastRow - 1).Copy
                    With Worksheets("baza_rls")
                    Set cell = .Range("A1:H1").Find(arrColumns(i), , xlValues, xlWhole, xlByColumns, xlNext)
                        .Cells(lastRow, 2).End(xlUp).Offset(1, cell.Column - 2).PasteSpecial xlPasteValues
                    End With
                End If
            Next
        End If
    End With
    Application.CutCopyMode = False
End Sub
ID posta: 336367 Skopiuj do schowka
 
 
cwirek
Forumowicz


Posty: 21
Wysłany: 18-12-2017, 14:45   

Makro działa za pierwszym razem idealnie, ale przy ponownym uruchomieniu dalej wkleja dokładnie w to samo miejsce, a nie dorzuca do już istniejaąej bazy w arkuszu "baza_rls"
ID posta: 336442 Skopiuj do schowka
 
 
dm 
Excel Expert


Wersja: Win Office 2013
Pomógł: 490 razy
Posty: 1331
Wysłany: 18-12-2017, 19:17   

Zamień jeszcze ten fragment
Kod:
                    Set cell = .Range("A1:H1").Find(arrColumns(i), , xlValues, xlWhole, xlByColumns, xlNext)
                        .Cells(lastRowB, 2).Offset(1, cell.Column - 2).PasteSpecial xlPasteValues
                    End With
ID posta: 336457 Skopiuj do schowka
 
 
cwirek
Forumowicz


Posty: 21
Wysłany: 21-12-2017, 17:32   

No niestety nadal mi nie działa to makro...
ID posta: 336610 Skopiuj do schowka
 
 
dm 
Excel Expert


Wersja: Win Office 2013
Pomógł: 490 razy
Posty: 1331
Wysłany: 21-12-2017, 20:54   

Zobacz teraz

Kopia test2-1.xlsm
Pobierz Plik ściągnięto 147 raz(y) 29.3 KB

ID posta: 336619 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