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.

M.Office wyszukiwanie numeru w kolumnie

karolczyzycki 15 Paź 2009 12:41 1564 4
  • #1 15 Paź 2009 12:41
    karolczyzycki
    Poziom 20  

    Witam.
    Mam pliki 1.xls który ma w kolumnie A wpisane niepowtarzające się numery.
    Drugi plik 2.xls do którego chcę skopiować numery, wszystki od ostatniego w pliku 1.
    M.Office wyszukiwanie numeru w kolumnie

    Mam takie kody, z których można skorzystać, bo działają, w innym pliku.
    I na ich podstawie wykonują się inne funkcje.
    Ale nie wiem jak to połączyć razem.

    Wyszukiwanie numeru i zaznaczanie komórki

    Code:
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    If Target.Row = 5 And Target.Column = 15 Then ' aktywuje się jeśli ta komórka zostanie zmieniona (6,12)
       
    Columns("A:A").Select  'szuka w kolumnie A numeru
     On Error Resume Next
     wiersz = Selection.Find(What:=Range("B2"), After:=ActiveCell, LookAt:=xlWhole).Row ' pobiera numer komórki  (B2)
     Cells(wiersz, 8).Select ' zaznacza kolumnę 1, w wierszu z serialem (B2)
    End If
    End Sub



    Kod kopiowanie wartości z komórki
    Code:
    Sub kopiuj_wartości2(ByVal cokopiujemy2 As String, linia2 As Integer, kolumna As Integer)
    
        Sheets("data2").Select
        Range(cokopiujemy2).Select
        Selection.Copy
        Sheets("data").Select
        Cells(linia2, kolumna).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    End Sub
     cokopiujemy2 = "C4"
        Call kopiuj_wartości2(cokopiujemy2, linia2, 5)



    Wiem jak zrobić i wyszukiwanie numeru w kolumnie i kopiowanie, ale zle gorzej z tym kopiowaniem "od" "do" ostatniej pustej
    ((To może byc nawet w jednym pliku, tak że kopiuje do kolumny obok, a ja później przerobię na dwa pliki.)

    0 4
  • #2 15 Paź 2009 13:59
    adamas_nt
    Moderator Programowanie

    Wykombinuj coś w ten deseń

    Code:
    odWrs = Sheets("Arkusz1").Range("A:A").Find(Sheets("Arkusz2").Range("A1").End(xlDown).Rows).Row + 1
    
    doWrs = Sheets("Arkusz1").Range("A1").End(xlDown).Row

    Sheets("Arkusz1").Activate
    Sheets("Arkusz1").Range(Cells(odWrs, 1), Cells(doWrs, 1)).Copy _
    Sheets("Arkusz2").Cells(Sheets("Arkusz2").Range("A1").End(xlDown).Row + 1, 1)


    Edit: To samo, ale bardziej "po ludzku"
    Code:
    wOstWrs = Sheets("Arkusz2").Range("A1").End(xlDown).Rows
    
    odWrs = Sheets("Arkusz1").Range("A:A").Find(wOstWrs).Row + 1
    doWrs = Sheets("Arkusz1").Range("A1").End(xlDown).Row
    doOstWrs = Sheets("Arkusz2").Range("A1").End(xlDown).Row + 1

    Sheets("Arkusz1").Activate
    Sheets("Arkusz1").Range(Cells(odWrs, 1), Cells(doWrs, 1)).Copy Sheets("Arkusz2").Cells(doOstWrs, 1)

    0
  • #3 15 Paź 2009 14:21
    karolczyzycki
    Poziom 20  

    Tamto działa.
    Ale miałem błąd jeśli arkusz2 był pusty (a tak też może się zdarzyć) więc dodałem warunek, że jeśli pusta to cała kolumna, to kopiuje całą kolumnę, ale też coś nie działa...

    Code:
    Sub Makro1()
    

    If (Range("A:A") = "") Then
      Sheets("Arkusz2").Range("A:A") = Sheets("Arkusz2").Range("A:A")
        Else
    wOstWrs = Sheets("Arkusz2").Range("A1").End(xlDown).Rows
    odWrs = Sheets("Arkusz1").Range("A:A").Find(wOstWrs).Row + 1
    doWrs = Sheets("Arkusz1").Range("A1").End(xlDown).Row
    doOstWrs = Sheets("Arkusz2").Range("A1").End(xlDown).Row + 1

    Sheets("Arkusz1").Activate
    Sheets("Arkusz1").Range(Cells(odWrs, 1), Cells(doWrs, 1)).Copy Sheets("Arkusz2").Cells(doOstWrs, 1)


    End Sub


    Jeszcze jedna sprawa, jesli kopiuje to z pliku z innego komputera przez sieć,
    nagrywam makro, ręcznie kopiuje jakąś komórkę (tylko po to żeby otrzymać kod gdziebędzie ścieżka)
    to makro wygląda tak:


    Code:
      Windows("plik.xls").Activate
    
         Range("A13").Select
        Selection.Copy
         Windows("plik2.xls").Activate
        Range("D12").Select
        ActiveSheet.Paste


    Bez ścieżki dostępu... Jaka komenda otwiera plik excela?
    zebym mógł podać ścieżke i nazwę pliku i makro otworzy plik

    0
  • #4 15 Paź 2009 14:58
    walek33
    Poziom 28  

    A może takie rozwiązanie?

    Code:
    Sub kopia()
    
        Sheets("Arkusz2").Activate
        Cells(1, 1).Activate
        ilosc_wierszy = 0
        Do
            ilosc_wierszy = ilosc_wierszy + 1
            badana = ActiveCell.Offset(ilosc_wierszy, 0).Value
        Loop While badana
        szukana = ActiveCell.Offset(ilosc_wierszy - 1, 0).Value
        Cells(ilosc_wierszy + 1, 1).Activate
        Sheets("Arkusz1").Activate
        Columns("A:A").Select
        wiersz = Selection.Find(what:=szukana, after:=ActiveCell, lookat:=xlWhole).Row + 1
        Cells(wiersz, 1).Select
        ilosc_wierszy = 0
        Do
            ilosc_wierszy = ilosc_wierszy + 1
            badana = ActiveCell.Offset(ilosc_wierszy, 0).Value
        Loop While badana
        Range(ActiveCell, ActiveCell.Offset(ilosc_wierszy - 1, 0)).Select
        Selection.Copy
        Sheets("Arkusz2").Activate
        Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
    End Sub

    Przy czym, żeby działało w momencie zmian w arkuszu źródłowym musisz je wywołać w:
    Code:
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Co prawda jest to trochę upierdliwe bo włącza się po każdej zmianie.

    0
  • #5 15 Paź 2009 18:09
    adamas_nt
    Moderator Programowanie

    karolczyzycki napisał:
    Bez ścieżki dostępu... Jaka komenda otwiera plik excela?
    Code:
    Sub Open_Copy()
    
    Dim fd As FileDialog
    Dim plik As Variant

    Set fd = Application.FileDialog(msoFileDialogFilePicker)
       
    With fd
        .Filters.Clear
        .Filters.Add "Pliki Excel", "*.xl*; *.xls*"
           
        If .Show = -1 Then
            For Each plik In .SelectedItems
                Workbooks.Open plik
                All = Split(plik, "\")
                plik2 = All(UBound(All))
            Next
        End If
    End With

    If WorksheetFunction.CountA(Workbooks(plik2).Sheets("Arkusz2").Range("A:A")) <> 0 Then
        wOstWrs = Workbooks(plik2).Sheets("Arkusz2").Range("A1").End(xlDown).Rows
        odWrs = Workbooks("1.xls").Sheets("Arkusz1").Range("A:A").Find(wOstWrs).Row + 1
        doWrs = Workbooks("1.xls").Sheets("Arkusz1").Range("A1").End(xlDown).Row
        doOstWrs = Workbooks(plik2).Sheets("Arkusz2").Range("A1").End(xlDown).Row + 1
       
        Workbooks("1.xls").Sheets("Arkusz1").Activate
        Sheets("Arkusz1").Range(Cells(odWrs, 1), Cells(doWrs, 1)).Copy _
        Workbooks(plik2).Sheets("Arkusz2").Cells(doOstWrs, 1)
    End If
    Set fd = Nothing

    End Sub

    karolczyzycki napisał:
    dodałem warunek, ale też coś nie działa...
    1. Brakuje znacznika "End If"
    2. W ten sposób nie sprawdzisz, czy pusta. Lepiej
    Code:
    If WorksheetFunction.CountA(Range("A:A")) = 0 Then


    Edit: Strzeliłem "byka". Makro w całości + poprawka :)

    0
  Szukaj w 5mln produktów