Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Kopiowanie wartości względem wartości w komórce

profesor · Fan Excela Wersja: Win Office 2019 Posty: 92

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 37 raz(y) 163.16 KB

Tajan · **Pomógł:** 5501 razy Posty: 11968

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.

profesor · Fan Excela Wersja: Win Office 2019 Posty: 92

Dzięki bardzo działa wszystko :)

Tajan · **Pomógł:** 5501 razy Posty: 11968

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