Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Przesuń wszystko do góry, jeśli zakres jest pusty

schuvi · Exceloholic Wersja: Win Office 2019 Posty: 158

Witajcie,

przeszukałem forum ale na takie rozwiązanie nie trafiłem.

A2:M400 mam różne dane.
Jeśli np. w wierszu A6:M6 zostaną wymazane wartości, to chce aby wszystko co było poniżej, zostało przesunięte do góry o jeden wiersz.

Jeśli np. usunięte zostanie więcej, dajmy A6:M10, to taka sama akcja. Wartości od A11 muszą się przesunąć do wolnego A6 itd.

Wiem że można to zrobić na zasadzie sortowania, ale wtedy muszę w makro podać według ktorej kolumny ma sortować. A sortowanie niestety komplikuje mi inne właściwości tabeli.
Ważne jest to, żeby zakres w którym ma działać makro, był stały, czyli A:M. Od kolumny N są inne funkcje.

Najlepiej żeby wyzwalać to makro przez CommandButton.

Pomożecie?

Pozdrówka

Radosław Poprawski · Wysłany: 07-12-2021, 19:46

przepluj tabelę przez PQ odfiltrowywując (blank) i null.

Nie ma potrzeby zabawy w VBa

schuvi · Exceloholic Wersja: Win Office 2019 Posty: 158

Masz na myśli poprzez PQ import i usuwanie pustych komórek?
Jako że inni użytkownicy potrafią nie wiele więcej niż tylko wpisać lub usunąć, nie są w stanie ogarnąć takiej operacji :-(

umiejead · Wysłany: 07-12-2021, 20:21

Załącz plik.
.

Tadek · Wysłany: 08-12-2021, 09:34

Czy zakres A2:M400 to jakaś stała tabela?
Czy jak "wymażesz" A6:M6 to zakres ma się zmnieszyć do A2:M399, czy ma zostać taki sam?
Czy zamiast wymazywania/usuwania nie możesz tego robić odpowiednim makrem, które usunie zaznaczony wiersz (wiersze) i wtedy przesunięcie nastapi automatycznie?

Maciej Gonet · Wysłany: 08-12-2021, 10:09

Brak załącznika i nie wiadomo o co dokładnie chodzi.
Można makrem, jak proponuje Tadek, ale można i bez makra. Tylko nie usuwać zawartości komórek klawiszem Delete, tylko przez Usuń komórki z menu Narzędzia główne > Komórki albo Usuń... z menu podręcznego. Albo skrót klawiaturowy Ctrl+"-" (Ctrl+minus). Oczywiście po wcześniejszym zaznaczeniu komórek do usunięcia.

Usuwanie_komórek.xlsx

Pobierz Plik ściągnięto 18 raz(y) 8.93 KB

schuvi · Exceloholic Wersja: Win Office 2019 Posty: 158

Witam,
jestem już. Załączam plik i odpowiadam na pytanie od Tadek.
Tak, zakres A2:M400 to stała tabela, i usówanie komórek czy wierszy nie wchodzi w rachubę.

W pliku jest wlaśnie kilka pustych wierszy w zakresie A:M, i teraz makrem chciałbym poprostu zlikwidować te wolne luki.

Pozdrawiam

Touren_test.xlsm

Pobierz Plik ściągnięto 24 raz(y) 313.66 KB

Maciej Gonet · Wysłany: 08-12-2021, 11:57

To nie jest tabela, tylko sformatowany zakres.
Proponuję kod (jest w dodanym Module1):

Kod:

Sub MoveRowsUp()
Dim lst As Long, i As Long, rw As Range, cnt As Long
lst = Cells(Rows.Count, 1).End(xlUp).Row
For i = lst To 2 Step -1
Set rw = Range(Cells(i, "A"), Cells(i, "M"))
If rw.Text = vbNullString Then
rw.Delete xlShiftUp
cnt = cnt + 1
End If
Next i
If cnt > 0 Then
i = Cells(Rows.Count, 1).End(xlUp).Row + 1
Set rw = Range(Cells(i, "A"), Cells(i, "M")).Resize(cnt)
rw.Insert xlShiftDown
End If
End Sub

Touren_test2.xlsm

Pobierz Plik ściągnięto 25 raz(y) 314.42 KB

Tadek · Wysłany: 08-12-2021, 12:14

Można również tak:

Kod:

Sub przesun_wiersze()
Dim ost&, w&, i&, k&
Dim dane()
With Sheets("Hauptdaten")
ost = .Cells(Rows.Count, "A").End(xlUp).Row
ReDim dane(1 To ost, 1 To 13)
For i = 2 To ost
If .Cells(i, 1) <> "" Then
w = w + 1
For k = 1 To 13
dane(w, k) = .Cells(i, k).Value
Next
End If
Next
If w > 0 Then
.Range("A2:M" & ost).ClearContents
.Range("A2").Resize(w, 13) = dane
End If
End With
End Sub

beret · Wysłany: 08-12-2021, 14:15

Maciej mam do Ciebie pytanie odnośnie tego fragmentu:

Kod:

Set rw = Range(Cells(i, "A"), Cells(i, "M"))
If rw.Text = vbNullString Then

to sprawdza czy zakres pusty, a jak to by wyglądało gdybym chciał sprawdzić czy zakres jest niepusty, któraś komórka wypełniona?

schuvi · Exceloholic Wersja: Win Office 2019 Posty: 158

Dziękuje Panowie bardzo.
Maciej Gonet, twoje rozwiązanie działało, ale nie tak jak chciałem. Kasowało pusty wiersz i wstawiało na dole nowy. Wszystko było by ok, ale w tym nowym nie było już żadnych formuł w zakresie dalszym od M (Dlatego ważne było dla mnie, by wszystko odbyło się AM). Ale zapiszę go sobie, bo może się przydać.

Tadek - Twoje rozwiązanie robi co trzeba. Dziękuje za szybka pomoc.

Pozdrawiam

Maciej Gonet · Wysłany: 08-12-2021, 20:48

Odpowiedź na pytanie bereta:
Jeśli właściwość Text zostanie użyta do zakresu komórek, to w wyniku otrzymamy:
- gdy komórki zawierają identyczną zawartość - tę zawartość (nie jest rozróżniana wielkość liter, w razie różnic wielkości liter zwracana jest zawartość pierwszej komórki zakresu, puste komórki są traktowane tak samo jak puste teksty),
- gdy komórki zawierają różną zawartość - wartość Null.
Zatem jeśli komórki są puste lub zawierają puste teksty można użyć testu:

Kod:

zakres.Text = vbNullString

Jeśli test chcemy przeprowadzić w drugą stronę, to sprawa trochę się komplikuje. Jeśli komórki miałyby różną zawartość, to można by sprawdzić:

Kod:

IsNull(zakres.Text)

Ale pozostaje przypadek, kiedy wszystkie testowane komórki są niepuste, ale mają taką samą zawartość. Wtedy funkcja sprawdzająca mogłaby wyglądać tak:

Kod:

Function Niepusty(test As Range) As Boolean
Niepusty = IsNull(test.Text)
If Not Niepusty Then Niepusty = test.Text <> vbNullString
End Function

Ale można również sprawdzenie przeprowadzić na innej zasadzie, wykorzystując funkcję ILE.NIEPUSTYCH:

Kod:

Application.CountA(zakres)>0

Tak będzie w tym przypadku prościej.

Odpowiedź na komentarz schuvi
Nie bardzo rozumiem, o czym piszesz. Mój kod działa tylko w obrębie kolumn A:M. Niczego nie zmienia poza tymi kolumnami. Uzupełniając brakujące wiersze w zakresie kolumn A:M kopiuje tylko formatowanie. A w tych ukrytych kolumnach (dalszych od M) zresztą nic nie było (poza pierwszymi wierszami). Nie wiem o jakie formuły Ci chodzi - najlepiej pisać konkretnie w takiej a takiej komórce ma być to i to.

beret · Wysłany: 09-12-2021, 07:49

Maciej, serdecznie dziękuję za powyższe wyjaśnienie. :hamer

schuvi · Exceloholic Wersja: Win Office 2019 Posty: 158

Maciej Gonet - zwracam honor. Ja skopałem sobie przez przypadek plik i dlatego nie działało.

Żeby nie tworzyć kolejnego posta, mam jeszcze inne pytanie:

Mam makro, które w pierwszym Sheet filtruje mi w zakresie według konkretnego kryterium i odnalezione kopiuje do odpowiedniego Sheet.
Przykład:
W "Hauptdaten" w zakresie A2:M400, filtruje w J2:J400 wedlug kryterium np 1. Wszystko co znajdzie z 1, kopiuje i przenosi zakres A2:M400 do Sheet "Tour1". Itd. 2 do 2, 3 do 3.
Wszystko działa jak powinno, ale...jesli nie znajdzie zadanego kryterium, kopiuje mi wszystko, innymi słowy, nie znajdzie nic z 1, to kopuije wszystko z zakresu A2:M400 i wkleja do Sheet "Tour1)

Próbowałem z

Kod:

If Not Range("I2:I400").Find(Tour, lookat:=xlWhole) Is Nothing Then 'Filtern
End If

, ale nici z tego, lub nie wiem jak to wkleić w Makro:

Proszę o pomoc, poniżej obcięte Makro. W oryginale jest do Tour 20, ale to nie ważne:

Kod:

Sub TourenAufteilen()
'
' TourenAufteilen Makro
'
' Tastenkombination: Strg+t
'
ActiveSheet.Unprotect Password:="tourenliste"
Range("A2:M400").Select
ActiveSheet.ShowAllData
ActiveSheet.Range("$A$1:$T$400").AutoFilter Field:=10, Criteria1:="1"
Application.CutCopyMode = False
Selection.Copy
Sheets("Tour1").Select
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Hauptdaten").Select
ActiveSheet.ShowAllData
ActiveSheet.Range("$A$1:$T$400").AutoFilter Field:=10, Criteria1:="2"
Application.CutCopyMode = False
Selection.Copy
Sheets("Tour2").Select
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Hauptdaten").Select
ActiveSheet.ShowAllData
ActiveSheet.Range("$A$1:$T$400").AutoFilter Field:=10, Criteria1:="3"
Application.CutCopyMode = False
Selection.Copy
Sheets("Tour3").Select
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Hauptdaten").Select
ActiveSheet.Range("$A$1:$T$400").AutoFilter Field:=10, Criteria1:="4"
Application.CutCopyMode = False
Selection.Copy
Sheets("Tour4").Select
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Hauptdaten").Select
ActiveSheet.Range("$A$1:$T$400").AutoFilter Field:=10, Criteria1:="5"
Application.CutCopyMode = False
Selection.Copy
Sheets("Tour5").Select
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Hauptdaten").Select
ActiveSheet.Range("$A$1:$T$400").AutoFilter Field:=10, Criteria1:="6"
Application.CutCopyMode = False
Selection.Copy
Sheets("Tour6").Select
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Hauptdaten").Select
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$T$400").AutoFilter Field:=10
Range("A2").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True
ActiveWorkbook.Save
End Sub

Maciej Gonet · Wysłany: 12-12-2021, 17:22

Moim zdaniem niepotrzebnie powtarzasz ten sam kod. To można kopiować w pętli. I nie potrzeba zmieniać selekcji. Zobacz taki kod:

Kod:

Sub TourenAufteilen()
'
' TourenAufteilen Makro
'
' Tastenkombination: Strg+t
'
Dim i As Long

' ActiveSheet.Unprotect Password:="tourenliste"
Application.ScreenUpdating = False
Sheets("Hauptdaten").Select
Range("A2:M400").Select
With ActiveSheet
For i = 1 To 6
If Not .Range("J2:J400").Find(i, lookat:=xlWhole) Is Nothing Then
.Range("$A$1:$T$400").AutoFilter Field:=10, Criteria1:=i
Selection.Copy Sheets("Tour" & i).Range("A2")
.Range("$A$1:$T$400").AutoFilter
End If
Next i
End With
Range("A2").Select
Application.ScreenUpdating = True
' ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True
' ActiveWorkbook.Save
End Sub

Touren_test3b.xlsm

Pobierz Plik ściągnięto 18 raz(y) 321.04 KB