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
Przesunięty przez: Kaper
19-09-2022, 11:27
Makro kopiujace dane z innego pliku
Autor Wiadomość
materka1996
Starszy Forumowicz


Posty: 38
Wysłany: 19-09-2022, 10:53   Makro kopiujace dane z innego pliku

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!
ID posta: 420621 Skopiuj do schowka
 
 
dj_majk 
Excel Expert



Zaproszone osoby: 1
Wersja: Win Office 2010
Pomógł: 382 razy
Posty: 1232
Wysłany: 19-09-2022, 20: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.
_________________
Pozdrawiam
Michał
ID posta: 420636 Skopiuj do schowka
 
 
materka1996
Starszy Forumowicz


Posty: 38
Wysłany: 20-09-2022, 11:52   

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
ID posta: 420651 Skopiuj do schowka
 
 
dj_majk 
Excel Expert



Zaproszone osoby: 1
Wersja: Win Office 2010
Pomógł: 382 razy
Posty: 1232
Wysłany: 20-09-2022, 13: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
_________________
Pozdrawiam
Michał
ID posta: 420654 Skopiuj do schowka
 
 
materka1996
Starszy Forumowicz


Posty: 38
Wysłany: 20-09-2022, 14:18   

Hm...

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

Invalid procedure call or argument.
ID posta: 420658 Skopiuj do schowka
 
 
dj_majk 
Excel Expert



Zaproszone osoby: 1
Wersja: Win Office 2010
Pomógł: 382 razy
Posty: 1232
Wysłany: 20-09-2022, 16: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
_________________
Pozdrawiam
Michał
ID posta: 420662 Skopiuj do schowka
 
 
materka1996
Starszy Forumowicz


Posty: 38
Wysłany: 21-09-2022, 10:16   

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?
ID posta: 420692 Skopiuj do schowka
 
 
dj_majk 
Excel Expert



Zaproszone osoby: 1
Wersja: Win Office 2010
Pomógł: 382 razy
Posty: 1232
Wysłany: 22-09-2022, 15:15   

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

przenoszenie.xlsm
Pobierz Plik ściągnięto 13 raz(y) 42.91 KB

_________________
Pozdrawiam
Michał
ID posta: 420733 Skopiuj do schowka
 
 
materka1996
Starszy Forumowicz


Posty: 38
Wysłany: 23-09-2022, 08:18   

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ć?
ID posta: 420745 Skopiuj do schowka
 
 
dj_majk 
Excel Expert



Zaproszone osoby: 1
Wersja: Win Office 2010
Pomógł: 382 razy
Posty: 1232
Wysłany: 23-09-2022, 08:39   

Tak, w procedurze zdarzeniowej CommandButton_Click dopisz:
Kod:
Private Sub cmbOK_Click()
unload me
Call Przenoszenie2(txtData.value)
End Sub
_________________
Pozdrawiam
Michał
ID posta: 420746 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.wip.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