Elektroda.pl
Elektroda.pl
X
Proszę, dodaj wyjątek www.elektroda.pl do Adblock.
Dzięki temu, że oglądasz reklamy, wspierasz portal i użytkowników.

VBA Excel - Makro do kopiowania danych z kilku plików CSV do poszczególnych kolu

ewskitomasz 07 Lip 2018 10:30 162 3
  • #1 07 Lip 2018 10:30
    ewskitomasz
    Poziom 3  

    Witam.

    Mam ok 60 plików CSV (pliki tekstowe oddzielone przecinkami) znajdują się w jednym folderze. Pliki mają różne nazwy (przykładowo: 21172001 6.28.18 13.07.05) każdy plik ma tyle samo kolum (po przecinku)
    wiersz pierwszy: a,b,c,d,e,f,g,h,i,
    wiersz drugi: 1,1,1,0,0.00,0.00,N-m,0,0
    wiersz trzeci: 1,1,1,0,0.00,0.00,N-m,0,0

    Potrzebuję makro które:
    1. Zamienia przecinki na kolumny
    2. Kopiuje kolumny ze wszystkich skoroszytów (w tym przypadku kolumna F) do jednego arkusza

    Na chwilę obecną posiadam makro które zamienia przecinki na kolumny i otwiera w nowych skoroszytach podzielone
    Plik z makrem musi znajdować się w folderze gdzie są pliki do rozdzielenia
    Proszę o pomoc.
    Kod poniżej:


    Sub scalaj_csv()

    Dim NazwaPlik As String ' zdefiniowanie zmiennej do przechowywania nazwy pliku
    Dim Lokalizacja As String ' zdefiniowanie zmiennej do przechowywania scieżki do katalogu
    Dim wbWyniki As Workbook ' skoroszyt gdzie będą wyniki
    Dim wbCSV As Workbook ' oryginalne skoroszyty z których będziemy kopiować
    Dim wiersz As Integer ' zdefiniowanie zmiennej typu liczbowego
    Dim ws As Object ' zdefiniowanej zmiennej obiektowej

    Lokalizacja = ThisWorkbook.Path & "\" ' Lokalizacja pliku
    NazwaPlik = Dir(Lokalizacja & "*.csv*") 'pobranie nazwy pliku csv
    Application.ScreenUpdating = False ' wyłączenie odświeżania
    Application.EnableEvents = False ' wyłaczenie obsługi zdarzeń
    Set wbWyniki = Workbooks.Add(xlWorksheet) 'storzenie nowego skoroszytu gdzie będziemy zapisywać
    i = 1 ' przypisanie zmiennej i wartości 1

    ' uruchomienie pętli, która będzie się wykonywała aż warunek bedzie spełniony
    Do While NazwaPlik <> vbNullString
    Set wbCSV = Workbooks.Open(Filename:=Lokalizacja & NazwaPlik, ReadOnly:=True) 'otwieranie pliku csv
    NazwaPlik = Left((Left(NazwaPlik, Len(NazwaPlik) - 5)), 29) 'wyciagniecie nazwy pliku bez roszeżenia
    wbCSV.Activate ' aktywacja pliku CSV
    ' przy pierwszym kopiowaniu, kopiujemy nagłówek, przy kolejnych plikach omijamy nagłóweg

    If i = 1 Then
    Range("A1").Select ' wiersz z nagłówkiem
    Else
    Range("A2").Select ' omijamy nagłówek
    End If

    Range(Selection, Selection.End(xlDown)).Select ' zaznaczenie zakresu do skopiowania
    Selection.Copy 'kopiowanie
    wbWyniki.Activate 'aktywacja pliku z wynikami

    ActiveSheet.Paste 'wklejenie danych z pliku CSV

    NazwaPlik = Dir 'pobranie nazwy pliku
    i = 2 ' zmiana wartości zmiennej i
    Loop

    Application.DisplayAlerts = False 'włączenie komunikatów
    wbWyniki.SaveAs Filename:=Lokalizacja & "scalone", FileFormat:=xlCSVMSDOS, CreateBackup:=False ' zapisanie pliku finalnego
    wbWyniki.Close SaveChanges:=False 'zamknięcie pliku finalnego
    Application.DisplayAlerts = True ' włączenie kominukatów
    Application.ScreenUpdating = True ' włączenie odświeżania
    Application.EnableEvents = True ' włączenie obsługi zdarzeń
    Set wbWyniki = Nothing ' zwolnienie pamieci z zmiennej obiektowej
    MsgBox "Pliki scalone"
    ThisWorkbook.Close SaveChanges:=False
    End Sub


    Proszę o pomoc

    0 3
  • #2 09 Lip 2018 12:03
    clubs
    Poziom 31  

    ewskitomasz napisał:
    Potrzebuję makro które:
    1. Zamienia przecinki na kolumny
    2. Kopiuje kolumny ze wszystkich skoroszytów (w tym przypadku kolumna F) do jednego arkusza

    Po co dwa makra jak można to zrobić jednym "w locie"?

    0
  • #3 10 Lip 2018 21:59
    ewskitomasz
    Poziom 3  

    Nie wiem jak :/

    0
  • #4 11 Lip 2018 19:14
    clubs
    Poziom 31  

    ewskitomasz napisał:
    Nie wiem jak :/

    Podam ci jeden ze sposobów :)
    Zapisz jako bat i wrzuć do katalogu z tymi csv i uruchom
    Kod: dos
    Zaloguj się, aby zobaczyć kod

    0
  Szukaj w 5mln produktów