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: 75244 Skopiuj do schowka Kopiowanie wartości względem wartości w komórce
Autor Wiadomość
profesor
Fan Excela


Wersja: Win Office 2019
Posty: 91
Wysłany: 21-11-2023, 13:46   Kopiowanie wartości względem wartości w komórce

Stworzyłem takie makro i niestety mam problem ze znalezieniem błędu.
Otóż w aktualnym stanie wpisuje wartości do wszystkich wartości w arkuszu nie zależnie od wartości. Chciałbym by znajdowało najpierw arkusz 1K (wartość pobrana z arkusza MENU komórka M4) następnie w tym arkuszu wpisane w kolumnie 2 typ a następnie z tych typów zakres numerów, czyli: arkusz 1K - > ZTW T1S - > 1 - 10 lub inny przykład arkusz 1K - > ZTW T1A - > 1-5.
Załączam plik podglądowy oraz zdjęcia z wytłumaczeniem.


Makro do wglądu:
Kod:
Sub Wstawianie_wytopów_odbiory()
Dim shName As String
Dim Rng As Range, rng1 As Range, cell As Range
Dim Liczba_od As Integer, Liczba_do As Integer
Liczba_od = Range("M10")
Liczba_do = Range("O10")
shName = Sheets("MENU").Range("M4").Value

With Sheets(shName)
    'szukamy kolumny typu
    Set Rng = .Columns(2).Find(What:=Sheets("MENU").Range("M8").Value, LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlNext)
    If Not Rng Is Nothing Then
     r = Rng.Row
     Set Rng = .Columns(2).Find(What:=Sheets("MENU").Range("M8").Value, LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlPrevious)
     If Not Rng Is Nothing Then
      i = Rng.Row
            Set Rng = .Range(.Cells(r, 2), .Cells(i, 2))
            'szukamy PIERWSZEGO wiersza numerów
            Set Rng = .Rows(r).Find(What:=Liczba_od, LookIn:=xlValues, lookat:=xlWhole, after:=Cells(r, 3), SearchDirection:=xlNext)
                If Not Rng Is Nothing Then
                p = Rng.Row
                'szukamy OSTATNIEGO wiersza numerów
            Set Rng = .Rows(i).Find(What:=Liczba_do, LookIn:=xlValues, lookat:=xlWhole, after:=Cells(i, 3), SearchDirection:=xlPrevious)
                If Not Rng Is Nothing Then ' tego ifa, aż do end if włącznie (poza linią i = rng.row) można by wyciąć o ile zawsze w tabeli będzie wartość do
                o = Rng.Row ' wykorzystałem niewykorzystaną tu do innych zastosowań zmienną
                Else 'tak nie powinno być, ale może ktoś poda np. za dużą? więc ostatni wypełniony wiersz
                    o = .Cells(Rows.Count, 3).End(xlUp).Row
                    End If
                Else
                MsgBox "Nie znaleziono początkowej wartości " & Liczba_od
                End If
            Else
            MsgBox "Nie znaleziono nazwy zbiornika" & Sheets("MENU").Range("M8").Value
            End If
    End If
'mając wierszE i kolumnę, wstawiamy wartość w całym zakresie
  If p > 1 Then
   k = 6
    Set Rng = .Range(.Cells(p, k), .Cells(o, k))
    Set Rng2 = .Range(.Cells(p, k + 1), .Cells(o, k + 1))
    Set Rng3 = .Range(.Cells(p, k + 2), .Cells(o, k + 2))
    Set Rng4 = .Range(.Cells(p, k + 3), .Cells(o, k + 3))
    Set Rng5 = .Range(.Cells(p, k + 4), .Cells(o, k + 4))
    Set Rng6 = .Range(.Cells(p, k + 5), .Cells(o, k + 5))
    o = Rng.Cells.Count ' zapamiętamy ile komórek
    If WorksheetFunction.CountBlank(Rng) = 0 Then
      MsgBox "Wszystkie wartości były już wykorzystane"
    Else
      Set Rng = Rng.SpecialCells(xlCellTypeBlanks)
      Rng.Value = Sheets("MENU").Range("S4")
      Rng2.Value = Sheets("MENU").Range("S6")
      Rng3.Value = Sheets("MENU").Range("S8")
      Rng4.Value = Sheets("MENU").Range("S10")
      Rng5.Value = Sheets("MENU").Range("S12")
      Rng6.Value = Sheets("MENU").Range("M12")
      MsgBox "Wprowadzono pomyślnie."
      If Rng.Cells.Count <> o Then MsgBox o - Rng.Cells.Count & " wartości było już wykorzystanych" ' tu można by rozbudować kod o listę wartości, które wcześniej były już wypełnione ixami, czy innymi znakami
    End If
  End If
End With
End Sub


BAZA WYTOPOW 2023.xlsm
Pobierz Plik ściągnięto 22 raz(y) 163.16 KB

ID posta: 431393 Skopiuj do schowka
 
 
Tajan


Pomógł: 5407 razy
Posty: 11795
Wysłany: 21-11-2023, 15:53   

Niestety, nie udało mi się uruchomić twojego pliku. Prawdopodobnie jest uszkodzony. Naniosłem kilka poprawek bez testowania. Sprawdź:
Kod:
Sub Wstawianie_wytopów_odbiory()
Dim shName As String
Dim Rng As Range, rng1 As Range, cell As Range
Dim tmpRng As Range, ile As Long
Dim Liczba_od As Integer, Liczba_do As Integer
Liczba_od = Range("M10")
Liczba_do = Range("O10")
shName = Sheets("MENU").Range("M4").Value

With Sheets(shName)
    'szukamy kolumny typu
    Set Rng = .Columns(2).Find(What:=Sheets("MENU").Range("M8").Value, _
               LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlNext)
    If Not Rng Is Nothing Then
        r = Rng.Row
        Set Rng = .Columns(2).Find(What:=Sheets("MENU").Range("M8").Value, _
                  LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlPrevious)
        If Not Rng Is Nothing Then
            i = Rng.Row
            '*** poprawka
            'Set Rng = .Range(.Cells(r, 2), .Cells(i, 2))
            Set Rng = .Range(.Cells(r, 3), .Cells(i, 3))
            'szukamy PIERWSZEGO wiersza numerów
            '*** poprawka
            'Set Rng = .Rows(r).Find(What:=Liczba_od, LookIn:=xlValues, _
                        lookat:=xlWhole, after:=Cells(r, 3), SearchDirection:=xlNext)
            Set tmpRng = Rng.Find(What:=Liczba_od, LookIn:=xlValues, _
                         lookat:=xlWhole, SearchDirection:=xlNext)
            If Not tmpRng Is Nothing Then
                p = Rng.Row
                'szukamy OSTATNIEGO wiersza numerów
                '*** poprawka
                'Set Rng = .Rows(i).Find(What:=Liczba_do, LookIn:=xlValues, _
                           lookat:=xlWhole, after:=Cells(i, 3), SearchDirection:=xlPrevious)
                Set tmpRng = Rng.Find(What:=Liczba_do, LookIn:=xlValues, _
                              lookat:=xlWhole, SearchDirection:=xlPrevious)
                If Not tmpRng Is Nothing Then ' tego ifa, aż do end if włącznie (poza linią i = rng.row) z-
                                              'można by wyciąć o ile zawsze w tabeli będzie wartość do
                    o = tmpRng.Row ' wykorzystałem niewykorzystaną tu do innych zastosowań zmienną
                Else   'tak nie powinno być, ale może ktoś poda np. za dużą? więc ostatni wypełniony wiersz
                    'o = .Cells(Rows.Count, 3).End(xlUp).Row
                    '*** poprawka
                    MsgBox "Nie znaleziono końcowej wartości " & Liczba_do
                    'jeżeli brak wartości, to informujemy aby nie wpisywać bzdur
                End If
            Else
                MsgBox "Nie znaleziono początkowej wartości " & Liczba_od
            End If
        Else
            MsgBox "Nie znaleziono nazwy zbiornika" & Sheets("MENU").Range("M8").Value
        End If
    End If
    'mając wiersz i kolumnę, wstawiamy wartość w całym zakresie
    If p > 1 Then
        k = 6
        Set Rng = .Range(.Cells(p, k), .Cells(o, k))
         '*** poprawka
        ile = WorksheetFunction.CountBlank(Rng)
        If ile = 0 Then
            MsgBox "Wszystkie wartości były już wykorzystane"
        Else
            If ile < Rng.Count Then
               MsgBox Rng.Count - ile & " wartości było już wykorzystanych"
               Set Rng = Rng.SpecialCells(xlCellTypeBlanks)
            End If
            Rng.Value = Sheets("MENU").Range("S4")
            Rng.Offset(, 1).Value = Sheets("MENU").Range("S6")
            Rng.Offset(, 2).Value = Sheets("MENU").Range("S8")
            Rng.Offset(, 3).Value = Sheets("MENU").Range("S10")
            Rng.Offset(, 4).Value = Sheets("MENU").Range("S12")
            Rng.Offset(, 5).Value = Sheets("MENU").Range("M12")
            MsgBox "Wprowadzono pomyślnie."
        End If
    End If
'
'            Set Rng2 = .Range(.Cells(p, k + 1), .Cells(o, k + 1))
'            Set Rng3 = .Range(.Cells(p, k + 2), .Cells(o, k + 2))
'            Set Rng4 = .Range(.Cells(p, k + 3), .Cells(o, k + 3))
'            Set Rng5 = .Range(.Cells(p, k + 4), .Cells(o, k + 4))
'            Set Rng6 = .Range(.Cells(p, k + 5), .Cells(o, k + 5))
'            o = Rng.Cells.Count                  ' zapamiętamy ile komórek
'            If WorksheetFunction.CountBlank(Rng) = 0 Then
'                MsgBox "Wszystkie wartości były już wykorzystane"
'            Else
'                Set Rng = Rng.SpecialCells(xlCellTypeBlanks)
'                Rng.Value = Sheets("MENU").Range("S4")
'                Rng2.Value = Sheets("MENU").Range("S6")
'                Rng3.Value = Sheets("MENU").Range("S8")
'                Rng4.Value = Sheets("MENU").Range("S10")
'                Rng5.Value = Sheets("MENU").Range("S12")
'                Rng6.Value = Sheets("MENU").Range("M12")
'                MsgBox "Wprowadzono pomyślnie."
'                If Rng.Cells.Count <> o Then MsgBox o - Rng.Cells.Count & " wartości było już wykorzystanych"
             ' tu można by rozbudować kod o listę wartości, które wcześniej były już wypełnione ixami, czy innymi znakami
'            End If
'        End If
End With
End Sub
Miejsca zmieniane zaznaczyłem odpowiednim komentarzem.
ID posta: 431400 Skopiuj do schowka
 
 
profesor
Fan Excela


Wersja: Win Office 2019
Posty: 91
Wysłany: 22-11-2023, 08:53   

Dzięki bardzo działa wszystko :)
ID posta: 431426 Skopiuj do schowka
 
 
Tajan


Pomógł: 5407 razy
Posty: 11795
Wysłany: 22-11-2023, 10:08   

Znalazłem błąd. Zamiast:
Kod:
          If Not tmpRng Is Nothing Then
                p = Rng.Row

powinno być:
Kod:
          If Not tmpRng Is Nothing Then
                p = tmpRng.Row
ID posta: 431429 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