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
ID tematu: 64600 Skopiuj do schowka Kopiowanie do Arkusza tylko kolumn z datami
Autor Wiadomość
cezaryfcb89 
Fan Excela


Posty: 76
Wysłany: 30-03-2019, 16:34   Kopiowanie do Arkusza tylko kolumn z datami

Heya mam pytanie czy jest może makro które po wyszukaniu w Kolumnie A dwóch dat występujących po sobie np: 18.03.2019 03-06-2019 ABS PLN 50zł (zawsze jest pierwsza data następnie spacja i druga data a następnie opis operacji) kopiowało je do następnego arkusza w całości razem z opisem. Zawsze w arkuszu 1 jest około 2000 wierszy i są wiersze nie tylko z opisami wcześniej przedstawionymi ale tak samo inne dane ale dane które chce skopiować do arkusza 2 zawsze na początku maja dwie daty w załączniku przesyłam przykład jak ma to wyglądać

Przykład.xlsm
Pobierz Plik ściągnięto 33 raz(y) 9.82 KB

ID posta: 365188 Skopiuj do schowka
 
 
ąćęłńóś
Excel Expert


Pomógł: 202 razy
Posty: 960
Wysłany: 30-03-2019, 18:14   

Raczej nie ma, ale można je napisać, np. :-> ... :
Kod:
Option Explicit

Sub kryncu_pyncu()
    Dim suw As Byte, w As Long: w = 1
    With Sheets("Arkusz1")
        Do Until .Cells(w, "A").Value = ""
            If IsDate(Replace(Split(Trim(.Cells(w, "A").Value), " ", -1, 1)(0), ".", "/", 1, -1, 1)) Then
                With Sheets("Dane")
                    With .Range("A" & .Rows.Count).End(xlUp)
                        If suw = 0 Then .Offset(suw, 0).Value = "Wybór danych": suw = 1
                        .Offset(suw, 0).Value = Sheets("Arkusz1").Cells(w, "A").Value
                    End With
                End With
            End If
            w = w + 1
        Loop
    End With
End Sub

Jak nie będzie działać, to popraw nazwę zakładki "Dane" ..
ID posta: 365190 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2126 razy
Posty: 7041
Wysłany: 30-03-2019, 18:48   

A ja zapodam rozwiązanie PowerQuery.
Kod:
let
    Źródło = Excel.CurrentWorkbook(){[Name="Tabela1"]}[Content],
    #"Wstawiono pierwsze znaki" = Table.AddColumn(Źródło, "Pierwsze znaki", each Text.Start([Kolumna1], 21), type text),
    #"Podzielono kolumnę według ogranicznika" = Table.SplitColumn(#"Wstawiono pierwsze znaki", "Pierwsze znaki", Splitter.SplitTextByDelimiter(" ", QuoteStyle.Csv), {"Pierwsze znaki.1", "Pierwsze znaki.2"}),
    #"Zmieniono typ" = Table.TransformColumnTypes(#"Podzielono kolumnę według ogranicznika",{{"Pierwsze znaki.1", type date}, {"Pierwsze znaki.2", type date}}),
    #"Usunięto błędy" = Table.RemoveRowsWithErrors(#"Zmieniono typ", {"Pierwsze znaki.1", "Pierwsze znaki.2"}),
    #"Usunięto kolumny" = Table.RemoveColumns(#"Usunięto błędy",{"Pierwsze znaki.1", "Pierwsze znaki.2"})
in
    #"Usunięto kolumny"
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 365191 Skopiuj do schowka
 
 
cezaryfcb89 
Fan Excela


Posty: 76
  Wysłany: 30-03-2019, 20:01   

Dzięki bardzo makro działa.
ID posta: 365193 Skopiuj do schowka
 
 
cezaryfcb89 
Fan Excela


Posty: 76
Wysłany: 04-04-2019, 11:51   

Tak jak wcześniej pisałem makro działa ale wyłapuje również dane których nie chciałbym takie jak:
970,08 + 57,28 - 50,00 + 8,07 = 985,43
956,06 + 76,98 - 50,00 + 8,18 = 991,22
991,03 + 46,29 - 50,00 + 7,93 = 995,25


Mam pytanie czy da się go jakoś poprawić (tak jak wcześniej pisałem wierszy jest bardzo dużo około 2-3 tyś. Wiersze z datami pobierane są w całości i makro działa prawie idealnie ale zdążają się w jednym arkuszu około 10 pozycji takich jak wcześniej skopiowałem przykładowych pozycji.

Kod:
Option Explicit

 Sub kryncu_pyncu()
     Dim suw As Byte, w As Long: w = 1
     With Sheets("Arkusz1")
         Do Until .Cells(w, "A").Value = ""
             If IsDate(Replace(Split(Trim(.Cells(w, "A").Value), " ", -1, 1)(0), ".", "/", 1, -1, 1)) Then
                 With Sheets("Dane")
                     With .Range("A" & .Rows.Count).End(xlUp)
                         If suw = 0 Then .Offset(suw, 0).Value = "Wybór danych": suw = 1
                         .Offset(suw, 0).Value = Sheets("Arkusz1").Cells(w, "A").Value
                     End With
                 End With
             End If
             w = w + 1
         Loop
     End With
 End Sub
ID posta: 365421 Skopiuj do schowka
 
 
Tajan


Pomógł: 4351 razy
Posty: 9667
Wysłany: 04-04-2019, 12:30   

Spróbuj zmienić:
Kod:
If IsDate(Replace(Split(Trim(.Cells(w, "A").Value), " ", -1, 1)(0), ".", "/", 1, -1, 1)) Then
na:
Kod:
If Application.Trim(.Cells(w, "A").Value) Like "##.##.#### ##-##-#### *" Then
ID posta: 365426 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2126 razy
Posty: 7041
Wysłany: 04-04-2019, 14:23   

Albo tak:
Kod:
Sub Filtruj()
    Dim matches        As Object
    Dim Tbl            As Variant
    Dim tmp            As String
    Dim i              As Long

    Tbl = Sheets("Arkusz1").Range("A1:A" & Sheets("Arkusz1").Cells(Rows.Count, 1).End(xlUp).Row)

    For i = 1 To UBound(Tbl)
        tmp = tmp & Tbl(i, 1) & vbCrLf
    Next i

    With CreateObject("vbscript.regexp")
        .MultiLine = True
        .Global = True
        .Pattern = "\d{2}\.\d{2}\.\d{4} \d{2}-\d{2}\-\d{4}.*(.*?)"
        Set matches = .Execute(tmp)
        ReDim Tbl_out(0 To matches.Count - 1, 0)
    End With

    For i = 0 To matches.Count - 1
        Tbl_out(i, 0) = matches(i).Value
    Next

    Sheets("Dane").Range("A1").Resize(i).Value = Tbl_out

    Set matches = Nothing
    Erase Tbl
    Erase Tbl_out
End Sub
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 365436 Skopiuj do schowka
 
 
ąćęłńóś
Excel Expert


Pomógł: 202 razy
Posty: 960
Wysłany: 04-04-2019, 17:01   

Oj, jakie ubogacenie się zaczęło ... :-> ... a już temat wyglądał na "może" martwe ... rozwiązanie ... :->
... można też zastosować "stopniowanie przez usuwanie-zastępowanie", co wydłuża co prawda "kota" o kolejne długości ogonka, ale i bardziej zabezpiecza przed "myszoma" ... :-> ... w razie czego można dokładać kolejne pułapki na nie.
Kod:
Option Explicit

Sub kryncu_pyncu()
    Dim suw As Byte, co As String, w As Long: w = 1
    With Sheets("Arkusz1")
        Do Until .Cells(w, "A").Value = ""
            co = Replace(Application.Trim(.Cells(w, "A").Value), ",", "_", 1, -1, 1)
            co = Replace(co, " + ", "_", 1, -1, 1)
            co = Replace(Split(co, " ", -1, 1)(0), ".", "/", 1, -1, 1)
            If IsDate(co) Then
                With Sheets("Dane")
                    With .Range("A" & .Rows.Count).End(xlUp)
                        If suw = 0 Then .Offset(suw, 0).Value = "Wybór danych": suw = 1
                        .Offset(suw, 0).Value = Sheets("Arkusz1").Cells(w, "A").Value
                    End With
                End With
            End If
            w = w + 1
        Loop
    End With
End Sub
ID posta: 365457 Skopiuj do schowka
 
 
cezaryfcb89 
Fan Excela


Posty: 76
Wysłany: 15-04-2019, 14:07   

Mam jeszcze jedno pytanie do Makra czy da się jeszcze go zmienić aby pobierał również dane z poniższych wierszy np. gdy w wierszu 1 występuje: 01.01.2018 01.02.2018 PRZELEW a dopiero w wierszu A4: PLN 123,00 (Chciałbym mieć w następnym arkuszu 01.01.2018 01.02.2018 PRZELEW Z KARTY PLN 123,00). A chciałbym aby makro działało tak jak wcześniej ale uwzględniało również tą opcje czyli jak w kolumnie A jest np.: 01.01.2018 01.02.2018 PRZELEW PLN 123,00 to mi kopiuje cały wiesz ale nie uwzględnia tego wyjątku.


Wiersz A1 01.01.2018 01.02.2018 PRZELEW
Wiersz A2 ZASILENIE KONTA; 11 0000 0000 0000 0000 0000 0000;
Wiersz A3 AXAXA; 01-000
Wiersz A4 PLN 123,00

Moje makro:

Kod:
Dim i&
Dim Plik_Zrodlowy As Variant
    'Szybkość!
    Application.ScreenUpdating = False
     ' Arkusz z którego są pobierane pliki nazwa Dane kopiuje dane do Arkusza1
     Dim suw As Byte, w As Long: w = 1
     With Sheets("Dane")
         Do Until .Cells(w, "A").Value = ""
             If Application.Trim(.Cells(w, "A").Value) Like "##.##.#### ##.##.#### *" Then
                 With Sheets("Arkusz1")
                     With .Range("A" & .Rows.Count).End(xlUp)
                         If suw = 0 Then .Offset(suw, 0).Value = " ": suw = 1
                         .Offset(suw, 0).Value = Sheets("Dane").Cells(w, "A").Value
                     End With
                 End With
             End If
             w = w + 1
         Loop
     End With


Kod i formuły zamykaj w znacznikach [Code].
Wyjątkowo poprawiłem.
umiejead

.
ID posta: 366096 Skopiuj do schowka
 
 
cezaryfcb89 
Fan Excela


Posty: 76
Wysłany: 16-04-2019, 17:53   

Kontynuacja tematu może w załączniku prześle przykład o co mi chodzi Arkusz1 dane wyjściowe Arkusz Dane Wynik o jaki mi chodzi. Chodzi mi o to czy da się to makro rozbudować.

Kopia Przykład-1.xlsm
Pobierz Plik ściągnięto 17 raz(y) 16.65 KB

ID posta: 366179 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1214 razy
Posty: 3598
Wysłany: 16-04-2019, 19:14   

Jeśli dane wyglądają jak podałeś w ostatnim załączniku to poniższy kod powinien spełniać warunki.
Wyniki zaczynają się od A1 w arkuszu 'Dane ' (zwróć uwagę, że na końcu nazwy arkusza jest spacja)
Kod:
Sub Daty_Opisy_kuma()
    Dim r  As Object
    Dim ms As String
    Dim a(), rws()
    Dim i As Integer, k As Integer

    With Sheets("Arkusz1")
        a = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
    End With
    ReDim rws(1 To UBound(a))
    Set r = CreateObject("VBScript.RegExp")
    With r
        .Global = True
        .IgnoreCase = True
        .Pattern = "^\d+\D\d+\D\d+\s\d+\D\d+\D\d+.*$"
        For i = 1 To UBound(a)
            ms = a(i, 1)
            If .Test(ms) Then
                k = k + 1
                rws(k) = i
            End If
        Next
    End With
    ReDim Preserve rws(1 To k)
    With Sheets("Dane ")
        .[A1].CurrentRegion.ClearContents
        .[A1].Resize(k) = Application.Index(a, Application.Transpose(rws), 1)
    End With
    Set r = Nothing
End Sub
Pozdrawiam.
ID posta: 366180 Skopiuj do schowka
 
 
Tajan


Pomógł: 4351 razy
Posty: 9667
Wysłany: 16-04-2019, 21:49   

Przerobione makro:
Kod:
Sub Makro()
Dim r As Long
Dim w As Long: w = 1

Const wzor1 = "##.##.#### ##[.-]##[.-]#### *"
Const wzor2 = "####.##.## ####[.-]##[.-]## PRZELEW"

Application.ScreenUpdating = False

With Sheets("Arkusz1")
     
     r = .Range("A" & .Rows.Count).End(xlUp).Row
   
    Do Until w > r
       
       Set kom = .Cells(w, "A")
       
       With Sheets("Dane ").Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
         
         If Application.Trim(kom.Value) Like wzor2 Then
             .Value = kom.Value & " Z KARTY " & kom.Offset(3, 0).Value
         ElseIf Application.Trim(kom.Value) Like wzor1 Then
             .Value = kom.Value
         End If
       
       End With
       
       w = w + 1
   
    Loop

End With

End Sub
Ale, zaznaczam, działać będzie w przykładowym pliku, który załączyłeś, bo opis problemu nie pasuje do wyniku w przykładowym pliku, przykładowy plik nie pasuje do makra, makro nie pasuje do opisu więc kod skleciłem na podstawie swoich domysłów i przypuszczeń. Czy będzie działać na oryginalnych danych nie wiem, bowiem skoro w opisie dajesz przykład: "01.01.2018 01.02.2018 PRZELEW" a w pliku masz "2018.01.01 2018.02.01 PRZELEW" to trudno zgadnąć jak ma być naprawdę.
ID posta: 366191 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.marketingNET.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