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: 75322 Skopiuj do schowka scalanie komórek i wstawianie wartości
Autor Wiadomość
zbysiomysio 
Stały bywalec Excelforum


Wersja: Win Office 2007
Posty: 390
Wysłany: 05-12-2023, 10:07   scalanie komórek i wstawianie wartości

Mam arkusz z danymi w których makro ukrywa niepotrzebne kolumny. W arkuszu tym mam scalone komórki B21:AF21 i w nich wstawioną formułę "=B4". Problem w tym, że zależy mi na tym, żeby zostały jednak scalone komórki w rzędzie 21 ale od pierwszej widocznej kolumny w w/w zakresie, czyli jeżeli mam np ukrytą kolumnę B i C, to makro rozdzieliłoby komórki B21:AF21, a następnie zostałyby scalone komórki D21:AF21 i w nich wstawiona wartość z komórki B4. Czy jest taka możliwość?

Zeszyt1.xlsm
Pobierz Plik ściągnięto 24 raz(y) 34.95 KB

ID posta: 431859 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Wersja: Win Office 2021
Pomógł: 1168 razy
Posty: 2675
Wysłany: 05-12-2023, 18:32   

Hej,
potestuj takie makro:
Kod:

Sub scal()
Dim i&, x&

x = 2
For i = 2 To 32
   If Columns(i).Hidden Then
      x = i
   Else
      Exit For
   End If
Next i
Range("B21:F21").UnMerge
Range(Cells(21, 2), Cells(21, x)).ClearContents
Range(Cells(21, x + 1), Cells(21, "AF")).Merge
Range(Cells(21, x + 1), Cells(21, x + 1)).Value = Range("B4").Value
End Sub

Pozdrawiam :lol:

scalanie.hidden.xlsm
Pobierz Plik ściągnięto 20 raz(y) 36.43 KB

ID posta: 431887 Skopiuj do schowka
 
 
zbysiomysio 
Stały bywalec Excelforum


Wersja: Win Office 2007
Posty: 390
Wysłany: 07-12-2023, 07:26   

hurgadion napisał/a:
Hej,
potestuj takie makro:

Dzięki wielkie. makro działa
ID posta: 431941 Skopiuj do schowka
 
 
zbysiomysio 
Stały bywalec Excelforum


Wersja: Win Office 2007
Posty: 390
Wysłany: 07-12-2023, 08:33   

hurgadion napisał/a:
Hej,
potestuj takie makro:

Mam jeszcze pytanie jak można zdefiniować numery wierszy, żeby ta sama czynność została wykonana również w wierszach 28, 35, 42, 50, 62 i 70. Zrobiłem to przez skopiowanie i zmianę nr wierszy kolumn j.n., ale pewnie można to uprościć:
Kod:
    Dim i&, x&
x = 2
For i = 2 To 32
   If Columns(i).Hidden Then
      x = i
   Else
      Exit For
   End If
Next i
Range("B21:F21").UnMerge
Range(Cells(21, 2), Cells(21, x)).ClearContents
Range(Cells(21, x + 1), Cells(21, "AF")).Merge
Range(Cells(21, x + 1), Cells(21, x + 1)).Value = Range("B4").Value
Range("B28:F28").UnMerge
Range(Cells(28, 2), Cells(28, x)).ClearContents
Range(Cells(28, x + 1), Cells(28, "AF")).Merge
Range(Cells(28, x + 1), Cells(28, x + 1)).Value = Range("B4").Value
Range("B35:F35").UnMerge
Range(Cells(35, 2), Cells(35, x)).ClearContents
Range(Cells(35, x + 1), Cells(35, "AF")).Merge
Range(Cells(35, x + 1), Cells(35, x + 1)).Value = Range("B4").Value
Range("B42:F42").UnMerge
Range(Cells(42, 2), Cells(42, x)).ClearContents
Range(Cells(42, x + 1), Cells(42, "AF")).Merge
Range(Cells(42, x + 1), Cells(42, x + 1)).Value = Range("B4").Value
Range("B50:F50").UnMerge
Range(Cells(50, 2), Cells(50, x)).ClearContents
Range(Cells(50, x + 1), Cells(50, "AF")).Merge
Range(Cells(50, x + 1), Cells(50, x + 1)).Value = Range("B4").Value
Range("B62:F62").UnMerge
Range(Cells(62, 2), Cells(62, x)).ClearContents
Range(Cells(62, x + 1), Cells(62, "AF")).Merge
Range(Cells(62, x + 1), Cells(62, x + 1)).Value = Range("B4").Value
Range("B70:F70").UnMerge
Range(Cells(70, 2), Cells(70, x)).ClearContents
Range(Cells(70, x + 1), Cells(70, "AF")).Merge
Range(Cells(70, x + 1), Cells(70, x + 1)).Value = Range("B4").Value

Najlepiej byłoby, żeby ta sama czynność w tych samych wierszach została również wykonana dla zakresu kolumn AH:BL i BN:CR.
ID posta: 431945 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Wersja: Win Office 2021
Pomógł: 1168 razy
Posty: 2675
Wysłany: 07-12-2023, 09:19   

Wydaje mi się, że da się Twoje makro skrócić do makra postaci:
Kod:

Sub scal_wiele()
Dim i&, x&, tbl

x = 2
For i = 2 To 32
   If Columns(i).Hidden Then
      x = i
   Else
      Exit For
   End If
Next i

tbl = Array(21, 28, 35, 42, 50, 62, 70)
For i = LBound(tbl) To UBound(tbl)
    Range("B" & tbl(i) & ":AF" & tbl(i)).UnMerge
    Range(Cells(tbl(i), 2), Cells(tbl(i), x)).ClearContents
    Range(Cells(tbl(i), x + 1), Cells(tbl(i), "AF")).Merge
    Range(Cells(tbl(i), x + 1), Cells(tbl(i), x + 1)).Value = Range("B4").Value
Next i
End Sub

Dla pozostałych kolumn trzeba przeprowadzić podobne rozumowanie, pozdrawiam :lol:
ID posta: 431948 Skopiuj do schowka
 
 
zbysiomysio 
Stały bywalec Excelforum


Wersja: Win Office 2007
Posty: 390
Wysłany: 07-12-2023, 09:26   

hurgadion napisał/a:
Wydaje mi się, że da się Twoje makro skrócić do makra postaci:

Dzięki wielkie
ID posta: 431949 Skopiuj do schowka
 
 
zbysiomysio 
Stały bywalec Excelforum


Wersja: Win Office 2007
Posty: 390
Wysłany: 08-12-2023, 07:55   

hurgadion napisał/a:
Wydaje mi się, że da się Twoje makro skrócić do makra postaci:

Zauważyłem jednak jeden błąd i nie bardzo wiem jak to poprawić (pewnie w tej pętli coś trzeba poprawić). Makro działa bez zarzutu jeżeli kolumna B i kolejne są ukryte. Natomiast jeżeli kolumna B jest odkryta wtedy są scalane komórki w kolejnych widocznych kolumnach, Kolumna B jest rozdzielona.

scalanie.hidden.xlsm
Pobierz Plik ściągnięto 15 raz(y) 38.83 KB

ID posta: 432000 Skopiuj do schowka
 
 
hurgadion 
ExcelSpec



Wersja: Win Office 2021
Pomógł: 1168 razy
Posty: 2675
Wysłany: 08-12-2023, 09:53   

Przetestuj w takim razie takie makro:
Kod:

Sub scal_wiele2()
Dim i&, x&, tbl

x = 1
For i = 2 To 32
   If Columns(i).Hidden Then
      x = i
   Else
      Exit For
   End If
Next i

tbl = Array(21, 28, 35, 42, 50, 62, 70)
For i = LBound(tbl) To UBound(tbl)
    If x > 1 Then
       Range("B" & tbl(i) & ":AF" & tbl(i)).UnMerge
       Range(Cells(tbl(i), 2), Cells(tbl(i), x)).ClearContents
       Range(Cells(tbl(i), x + 1), Cells(tbl(i), "AF")).Merge
       Range(Cells(tbl(i), x + 1), Cells(tbl(i), x + 1)).Value = Range("B4").Value
    Else
       Range("B" & tbl(i) & ":AF" & tbl(i)).Merge
    End If
Next i
End Sub

Powinno działać także gdy kolumna B jest odkryta :lol:

scalanie.hidden2.xlsm
Pobierz Plik ściągnięto 16 raz(y) 37.79 KB

ID posta: 432005 Skopiuj do schowka
 
 
zbysiomysio 
Stały bywalec Excelforum


Wersja: Win Office 2007
Posty: 390
Wysłany: 08-12-2023, 13:22   

hurgadion napisał/a:
Przetestuj w takim razie takie makro:

Dzięki wielkie. Makro śmiga bez zarzutów
ID posta: 432016 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