Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - kopiowanie kolumn pomiędzy skoroszytami

cwirek · Forumowicz Posty: 21

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

dm · 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

cwirek · Forumowicz Posty: 21

To makro nie robi tego co chcę. Kolejność kolumn w "dane" nie pokrywa się z kolejnością z "baza_rls".

dm · 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

cwirek · Forumowicz Posty: 21

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"

dm · 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

cwirek · Forumowicz Posty: 21

No niestety nadal mi nie działa to makro...

dm · Wysłany: 21-12-2017, 20:54

Zobacz teraz

Kopia test2-1.xlsm

Pobierz Plik ściągnięto 147 raz(y) 29.3 KB