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.

Excel - makro - kopiowanie pod zadanym warunkiem

baalzag 13 Wrz 2010 15:55 4053 7
  • #1 13 Wrz 2010 15:55
    baalzag
    Poziom 8  

    Witam,
    próbowałem już kilku sposobów na rozwiązanie mojego problemu, ale niestety nic konstruktywnego nie udało mi się stworzyć.

    O co chodzi: pragnę stworzyć makro które kopiowałoby wybrane elementy z Arkusza1
    Przykład:

    1) mamy Arkusz1 z ID klienta (powiedzmy, że mamy 1000 pozycji) , przypisany mu wiersz chce uzupełnić o date logowania się np. na koncie, informacje takie dostaje w oddzielnym pliku( nazwijmy go Plik2), kóry oczywiście nie zawiera wszysktich klientów, są to dane wybiórcze, itd.( informacje dostaje codziennie w oddzielnym pliku, każdy ma średnio 30 pozycji)
    2) chcę następnie skopiować do Arkusza1 tylko te dane, w których ID klienta jest takie samo ( ID występuje również w tym oddzielnym pliku), aby uniknąć sytuacji, że kogoś pominąłem lub się pomyliłem przy "ręcznym" kopiowaniu
    3) chcę uniknąc sortowania danych w Arkuszu1, by mieć klarowny obraz sytuacji, na jakim etapie jest klient, tym samym nie mogę użyć funkcji vlookup

    jak narazie mój kod kopiuje tylko wybrane elementy z arkusza, aż do ostatniej komórki zawierającej dane, potrzeba mi wkleić kolejną kolumnę, która używałaby funkcji matchowania po ID

    Sub Macro()


    Workbooks.Open Filename:= _
    "H:\czesciowe\akty_test\01_DOB_A_ROZMOWA1.xls"
    ActiveSheet.Range("L2", ActiveSheet.Range("L2").End(xlDown)).Select
    ActiveCell.FormulaR1C1 = "=IF(RC="""",0,1)"
    Range("L2").AutoFill Destination:=Range("L2:L" & Range("K2").End(xlDown).Row)
    ActiveSheet.Range("A2", ActiveSheet.Range("K2").End(xlDown)).Select
    Selection.Copy
    Windows("MASTER-FILE.xls").Activate
    ActiveSheet.Range("A3").End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
    Windows("01_DOB_A_ROZMOWA1.xls").Activate
    ActiveSheet.Range("L2", ActiveSheet.Range("L2").End(xlDown)).Select
    Selection.Copy
    Windows("MASTER-FILE.xls").Activate
    ActiveSheet.Range("P3").End(xlDown).Offset(1, 0).Select
    ActiveSheet.Paste
    ActiveSheet.Range("Q3").End(xlDown).Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=TODAY()-RC[-6]"
    ActiveSheet.Range("Q3").End(xlDown).Offset(1, 0).Select
    Range("Q3").AutoFill Destination:=Range("Q3:Q" & Range("K3").End(xlDown).Row)
    ActiveSheet.Range("R3").End(xlDown).Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=RC[-7]+30"
    ActiveSheet.Range("R3").End(xlDown).Offset(1, 0).Select
    Range("R3").AutoFill Destination:=Range("R3:R" & Range("K3").End(xlDown).Row)
    ActiveSheet.Range("S3").End(xlDown).Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=DAYS360(TODAY(),RC[-8])+30"
    ActiveSheet.Range("S3").End(xlDown).Offset(1, 0).Select
    Range("S3").AutoFill Destination:=Range("S3:S" & Range("K3").End(xlDown).Row), Type:=xlFillCopy
    ActiveSheet.Range("A3").End(xlDown).Offset(1, 0).Select
    Windows("01_DOB_A_ROZMOWA1.xls").Activate
    ActiveWindow.Close
    End Sub

    Z góry dziękuję za pomoc

    0 7
  • #2 14 Wrz 2010 10:24
    baalzag
    Poziom 8  

    Proszę pomóżcie!

    0
  • #3 14 Wrz 2010 15:01
    adamas_nt
    Moderator Programowanie

    Nikt nie chce Ci niczego wytykać i dlatego pewnie brak odzewu.
    Ale co mi tam...
    Nie specjalnie interesuje nas wynik z nagrywarki makr bo z "normalnym" VBA ma on niestety niewiele wspólnego :) Powtarzające się ActiveSheet, nadmiarowe i niepotrzebne Select itp rozmywa tylko sens. Cóż, nic lepszego jeszcze nie wymyślono. Założę się, że gdyby ogłosić konkurs na skrócenie tej procedury, ktoś zmieściłby ją w kilku linijkach.

    Z tego co zrozumiałem chcesz uzupełnić wiersze w dane z innego pliku. Nic tu skomplikowanego jeśli wiadomo co, skąd i gdzie ma być kopiowane. Wrzuć lepiej pliki zawierające kilka wierszy danych (nie muszą przecież być prawdziwe), koniecznie w układzie i formacie tych prawdziwych + owoce Twoich zmagań.

    Z drugiej strony: Skorzystanie z "szukajki" i przejrzenie wyników z pewnością pomogłoby Ci w znalezieniu odpowiedzi lub chociażby zadania konkretnych pytań...

    0
  • #4 15 Wrz 2010 10:52
    baalzag
    Poziom 8  

    w takim razie przesyłam plik, w którym wyjaśniam w czym tkwi problem:
    do sheet1, który jest naszym master-filem ladujemy informacje z Sheet2, sęk w tym by przenieść informacje do odpowiedniego wiersza. Modulo musi się zgadzać. W sheet1 musi zostać zachowana kolejność. Potrzebne mi makro, które robiło by to automaczynie, nie zważając na liczbe wierzy.

    Z góry dziękuje za pomoc

    0
  • #6 23 Wrz 2010 10:41
    baalzag
    Poziom 8  

    Mój plik główny ma trochę inny uklad niż podany w pliku, który był tylko próbką.
    Do rzeczy:
    - dane będe kopiowane do Glowny_Plik.xls, od kolumny T do AB włącznie, łacznie 9 kolumn
    - dane do kopiowania pobierane z Plik_z_inf_zwrotnym.xls, od kolumny N do V

    chodzi o tym by kopiowac dane z Pliku zwrotnego i wklejac je w odpowiednie wiersze, kluczem jest tutaj indywidualne modulo

    nie wiem gdzie jest blad w tym kodzie:

    Code:
    Option Explicit
    
    Dim x As Long, y As Integer, suma As Double
    Sub Pobierz()
    On Error GoTo koniec
    Dim fd As FileDialog, ark As Workbook, i As Long
    Dim plik As Variant, modulo As String
    Dim thWkb As String, ostWrs As Long, wrs As Long

      Set fd = Application.FileDialog(msoFileDialogFilePicker)
      Application.ScreenUpdating = False
     
      With fd
          .Filters.Clear
          .Filters.Add "Pliki Excel", "*.xl*; *.xls*"
          .AllowMultiSelect = False
             
          If .Show = -1 Then
              For Each plik In .SelectedItems
                 
                  thWkb = ThisWorkbook.Name
                  Workbooks.Open Filename:=plik
                  Set ark = Workbooks(Workbooks.Count)
                  Sheets(1).Select
                  ostWrs = Range("H65536").End(xlUp).Row
              Next
          End If
      End With
     
      With Workbooks(thWkb).Sheets(1)
        For i = 9 To ostWrs
            modulo = ark.Sheets(1).Cells(i, 2)
            wrs = .Range("D:D").Find(modulo, LookAt:=xlWhole).Row
            .Cells(wrs, 20) = ark.Sheets(1).Cells(i, 14): .Cells(wrs, 20).NumberFormat = "m/d/yyyy"
            .Cells(wrs, 21) = ark.Sheets(1).Cells(i, 15)
            .Cells(wrs, 22) = ark.Sheets(1).Cells(i, 16)
            .Cells(wrs, 23) = ark.Sheets(1).Cells(i, 17)
            .Cells(wrs, 24) = ark.Sheets(1).Cells(i, 18)
            .Cells(wrs, 25) = ark.Sheets(1).Cells(i, 19)
            .Cells(wrs, 26) = ark.Sheets(1).Cells(i, 20)
            .Cells(wrs, 27) = ark.Sheets(1).Cells(i, 21)
            .Cells(wrs, 28) = ark.Sheets(1).Cells(i, 22)
            Application.ScreenUpdating = True
        Next
      End With
      ark.Close
    koniec:
      Set fd = Nothing
      Set ark = Nothing
    End Sub

    0
  • Pomocny post
    #7 23 Wrz 2010 18:38
    adamas_nt
    Moderator Programowanie

    Wklej do modułu pliku "Glowny_Plik.xls"

    Code:
    Option Explicit
    
    Sub Pobierz()
    On Error GoTo koniec
    Dim fd As FileDialog, ark As Workbook, i As Long
    Dim plik As Variant, modulo As String
    Dim thWkb As String, ostWrs As Long, wrs As Long
      Set fd = Application.FileDialog(msoFileDialogFilePicker)
      Application.ScreenUpdating = False
     
      With fd
          .Filters.Clear
          .Filters.Add "Pliki Excel", "*.xl*; *.xls*"
          .AllowMultiSelect = False
             
          If .Show = -1 Then
              For Each plik In .SelectedItems
                 
                  thWkb = ThisWorkbook.Name
                  Workbooks.Open Filename:=plik
                  Set ark = Workbooks(Workbooks.Count)
                  Sheets(1).Select
                  ostWrs = Range("D65536").End(xlUp).Row
              Next
          End If
      End With
     
      With Workbooks(thWkb).Sheets(1)
        For i = 3 To ostWrs
            modulo = ark.Sheets(1).Cells(i, 4)
            wrs = .Range("D:D").Find(modulo, LookAt:=xlWhole).Row
            .Cells(wrs, 20) = ark.Sheets(1).Cells(i, 14): .Cells(wrs, 20).NumberFormat = "m/d/yyyy"
            .Cells(wrs, 21) = ark.Sheets(1).Cells(i, 15)
            .Cells(wrs, 22) = ark.Sheets(1).Cells(i, 16)
            .Cells(wrs, 23) = ark.Sheets(1).Cells(i, 17)
            .Cells(wrs, 24) = ark.Sheets(1).Cells(i, 18)
            .Cells(wrs, 25) = ark.Sheets(1).Cells(i, 19)
            .Cells(wrs, 26) = ark.Sheets(1).Cells(i, 20)
            .Cells(wrs, 27) = ark.Sheets(1).Cells(i, 21)
            .Cells(wrs, 28) = ark.Sheets(1).Cells(i, 22)
        Next
      End With
      ark.Close savechanges:=False
    koniec:
      Application.ScreenUpdating = True
      Set fd = Nothing
      Set ark = Nothing
    End Sub

    0
  • #8 23 Wrz 2010 19:57
    baalzag
    Poziom 8  

    dziękuje, jakie to proste teraz ;)
    ogromnie dziękuje za pomoc!

    0