Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Makro kopiujace dane z innego pliku

materka1996 · Starszy Forumowicz Wersja: Win Office 365 Posty: 51

Dzień Dobry,

Mamy zrobiony plik bazowy, gdzie będzie utrzymane makro. Będziemy miec w nim 3 arkusze.
w 1 arkuszu wyzwalamy makro przyciskiem (przycisk dam rade zrobic sam)
w 2 arkuszu o nazwie ruchy kopiujemy dane umieszczone w C:\...\raport20220919(dzisiejsza data zawsze w formacie YYYYMMDD) do tego pliku z makrem.
W pliku skąd kopiujemy dane mamy nazwe arkusza: z_vre_supply_chain_20220913 - data jest zawsze "dzisiejsza" wiec lepiej wziac w makrze zapisać otworz raport, skopiuj aktywny arkusz do naszego z Makrem w zakladce: ruchy.
w 3 arkuszu analogiczna sytuacja jak w 2 tylko w naszym arkuszu z makrem bedziemy mieli arkusz o nazwie stock a w pliku skąd pobieramy dane z lokalizacji C:\...\raport220220919 (dzisiejsza data zawsze w formacie YYYYMMDD) do tego pliku. W pliku skad pobieramy dane arkusz jest tak samo tylko jeden i ma nazwe: zrm07mlbs_2_20220913(data zawsze bedzie dzisiejsza).

Dzięki za jakokolwiek pomoc!

dj_majk · Wysłany: 19-09-2022, 21:00

materka1996, proponuję to makro:

Kod:

Sub Przenoszenie()
Dim wb As Workbook
Dim wsRuchy As Worksheet
Dim wsStock As Worksheet
Dim wbBaza As Workbook
Dim ws As Worksheet
Dim wsSupp As String
Dim wsZrm As String
Dim r As Range
Dim pathQ As String
Dim currDate As String

currDate = Format(Now, "yyyymmdd")
pathQ = "C:\....Twoja scieżka...." & "raport" & currDate & ".xlsx"
Set wb = ThisWorkbook
Set wsRuchy = wb.Worksheets("Ruchy")
Set wsStock = wb.Worksheets("Stock")
Set wbBaza = GetObject(pathQ)

wsSupp = "z_vre_supply_chain_" & currDate
wsZrm = "zrm07mlbs_2_" & currDate

For Each ws In wbBaza.Worksheets
With ws
If .Name Like wsSupp Then
Set r = .UsedRange
With wsRuchy
.Cells.ClearContents
.[a1].Resize(r.Rows.Count, r.Columns.Count) = r.Value
End With
ElseIf .Name Like wsZrm Then
Set r = .UsedRange
With wsStock
.Cells.ClearContents
.[a1].Resize(r.Rows.Count, r.Columns.Count) = r.Value
End With
End If
End With
Next

wbBaza.Close
Set wbBaza = Nothing
End Sub

Nie podałeś czy nazwa pliku ma składać się z ciągu znaków "raport" data dzisiejsza czy tylko folder ma mieć taką nazwę. Jeżeli tak to w prosty sposób możesz przerobić powyższy kod i dostosować do swoich potrzeb.

materka1996 · Starszy Forumowicz Wersja: Win Office 365 Posty: 51

Cześć Majk,

Makro wyrzuca blad przy: Set wbBaza = GetObject(pathQ) a to znaczy ze ma problem z lokalizacją plików.

Nazwałem w uproszczeniu raport, zeby sobie to dostosowac, ale chyba nie bedzie tak prosto.

Kod:

Sub Przenoszenie()
Dim wb As Workbook
Dim wsRuchy As Worksheet
Dim wsStock As Worksheet
Dim wbBaza As Workbook
Dim ws As Worksheet
Dim wsSupp As String
Dim wsZrm As String
Dim r As Range
Dim pathQ As String
Dim currDate As String

currDate = Format(Now, "yyyymmdd")
pathQ = "C:\mojalokalizacja\Feforaport\z_vre_supply_chain_" & currDate & ".csv"
Set wb = ThisWorkbook
Set wsRuchy = wb.Worksheets("Ruchy")
Set wsStock = wb.Worksheets("Stock")
Set wbBaza = GetObject(pathQ)

wsSupp = "z_vre_supply_chain_" & currDate
wsZrm = "zrm07mlbs_2_" & currDate

For Each ws In wbBaza.Worksheets
With ws
If .Name Like wsSupp Then
Set r = .UsedRange
With wsRuchy
.Cells.ClearContents
.[a1].Resize(r.Rows.Count, r.Columns.Count) = r.Value
End With
ElseIf .Name Like wsZrm Then
Set r = .UsedRange
With wsStock
.Cells.ClearContents
.[a1].Resize(r.Rows.Count, r.Columns.Count) = r.Value
End With
End If
End With
Next

wbBaza.Close
Set wbBaza = Nothing
End Sub

W zasadzie w samym kodzie brakuje mi jeszcze nawiązania z pobraniem 2 pliku:
1 pliku o nazwie z_vre_supply_chain_YYYYMMDD pobieramy dane z arkusza: z_vre_supply_chain_YYYYMMDD.csv i wklejenie do ruchy z makrem.
2 pliku o nazwie: zrm07mlbs_2_YYYYMMDD skopiowanie do pliku z makrem(stock) arkusza o nazwie: zrm07mlbs_2_YYYYMMDD.csv

dj_majk · Wysłany: 20-09-2022, 14:23

materka1996, nic nie mówiłeś, że ma to być plik *.csv. Proponuję ten kod:

Kod:

Sub Przenoszenie()
Dim wb As Workbook
Dim wsRuchy As Worksheet
Dim pathQ As String
Dim currDate As String
Dim tbl() As Variant
Dim fso As Object
Dim i As Long
Dim FileCsv As Object
Dim znak As String

currDate = Format(Now, "yyyymmdd")
pathQ = "C:\mojalokalizacja\Feforaport\z_vre_supply_chain_" & currDate & ".csv"
znak = "," 'ten ktory rozdziela
Set wb = ThisWorkbook
Set wsRuchy = wb.Worksheets("Ruchy")
Set fso = CreateObject("scripting.filesystemobject")

i = 1
With fso
Set FileCsv = .OpenTextFile(pathQ, ForReadingCsv)
With FileCsv
Do While Not .AtEndOfStream
tempTxt = .ReadLine
tbl = Split(tempTxt, znak)
wsRuchy.Cells(i, 1).Resize(, UBound(tbl) + 1) = tbl
i = i + 1
tbl = Empty
Loop
.Close
End With
End With
End Sub

materka1996 · Starszy Forumowicz Wersja: Win Office 365 Posty: 51

Hm...

Wyrzuca błąd na tej linii "Set FileCsv = .OpenTextFile(pathQ, ForReadingCsv)"

Invalid procedure call or argument.

dj_majk · Wysłany: 20-09-2022, 17:32

Faktycznie zgubiłem zmienną ForReadingCsv . Dostosuj ten kod:

Kod:

Sub Przenoszenie()
Dim wb As Workbook
Dim wsRuchy As Worksheet
Dim pathQ As String
Dim currDate As String
Dim tbl As Variant
Dim fso As Object
Dim i As Long
Dim FileCsv As Object
Dim znak As String
Dim ForReadingCsv As Integer

currDate = Format(Now, "yyyymmdd")
pathQ = "C:\mojalokalizacja\Feforaport\z_vre_supply_chain_" & currDate & ".csv"
znak = "," 'ten ktory rozdziela
Set wb = ThisWorkbook
Set wsRuchy = wb.Worksheets("Ruchy")
Set fso = CreateObject("scripting.filesystemobject")
ForReadingCsv = 1

i = 1
With fso
Set FileCsv = .OpenTextFile(pathQ, ForReadingCsv)
With FileCsv
Do While Not .AtEndOfStream
tempTxt = .ReadLine
tbl = Split(tempTxt, znak)
wsRuchy.Cells(i, 1).Resize(, UBound(tbl) + 1) = tbl
i = i + 1
tbl = Empty
Loop
.Close
End With
End With
End Sub

materka1996 · Starszy Forumowicz Wersja: Win Office 365 Posty: 51

Dzięki Michał,

Suber robota!.

Końcowy efekt wygląda:

Kod:

Sub Przenoszenie2()
Dim wb As Workbook
Dim wsRuchy As Worksheet
Dim pathQ As String
Dim currDate As String
Dim tbl As Variant
Dim fso As Object
Dim i As Long
Dim FileCsv As Object
Dim znak As String
Dim ForReadingCsv As Integer

currDate = Format(Now, "yyyymmdd")
pathQ = "C:\Users\\Feforaport\z_vre_supply_chain_" & currDate & ".csv"
znak = ";" 'ten ktory rozdziela
Set wb = ThisWorkbook
Set wsRuchy = wb.Worksheets("Ruchy")
Set fso = CreateObject("scripting.filesystemobject")
ForReadingCsv = 1

i = 1
With fso
Set FileCsv = .OpenTextFile(pathQ, ForReadingCsv)
With FileCsv
Do While Not .AtEndOfStream
tempTxt = .ReadLine
tbl = Split(tempTxt, znak)
wsRuchy.Cells(i, 1).Resize(, UBound(tbl) + 1) = tbl
i = i + 1
tbl = Empty
Loop
.Close
pathQ = "C:\Users\\Feforaport\zrm07mlbs_2_" & currDate & ".csv"
znak = ";" 'ten ktory rozdziela
Set wb = ThisWorkbook
Set wsRuchy = wb.Worksheets("Stock")
Set fso = CreateObject("scripting.filesystemobject")
ForReadingCsv = 1

i = 1
With fso
Set FileCsv = .OpenTextFile(pathQ, ForReadingCsv)
With FileCsv
Do While Not .AtEndOfStream
tempTxt = .ReadLine
tbl = Split(tempTxt, znak)
wsRuchy.Cells(i, 1).Resize(, UBound(tbl) + 1) = tbl
i = i + 1
tbl = Empty
Loop
.Close

End With
End With
End With
End With
End Sub

Mam tylko jedno przemyślenie teraz. Te raporty mają sie kalkulować w zaleznosci od wydań produktow. W przypadku Poniedziałku, stock bedzie mnie interesować na dzisiaj. Ale zakladka wydania powinny być z soboty.

Zastanawiam sie jak to rozwiazać, moze w przypadku pierwszego raportu: z_vre_supply_chain_" & currDate & ".csv" żeby to uzytkownik podawał currDate. W przypadku Poniedzialku, raport trzeba by brać z Soboty, bo na koniec operacji piątkowych w tym raporcie beda dane.

Chyba ze przekombinowuje, moze latwiej bedzie zrobić male makro pomocnicze ktore zmienia date sobotnią na poniedzialkowa pliku z_vre_supply_chain_" ".csv" a nastepnie makro wyzwalane.
Ktoś miał moze podobne problemy weekendów?

dj_majk · Wysłany: 22-09-2022, 16:15

W załączeniu plik, gdzie możesz wstawić żądaną datę lub pozostawić dzisiejszą.

przenoszenie.xlsm

Pobierz Plik ściągnięto 32 raz(y) 42.91 KB

materka1996 · Starszy Forumowicz Wersja: Win Office 365 Posty: 51

Cześć Michał,

Super działa! mam jedną mikro rekomendację, po wpisaniu daty zostaje cały czas box z prosba o wpisanie, można jakoś go po wpisaniu daty z automatu wyłączyć?

dj_majk · Wysłany: 23-09-2022, 09:39

Tak, w procedurze zdarzeniowej CommandButton_Click dopisz:

Kod:

Private Sub cmbOK_Click()
unload me
Call Przenoszenie2(txtData.value)
End Sub