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: 64298 Skopiuj do schowka Automatyczne uzupełnianie kolumn
Autor Wiadomość
Tadek
Excel Expert


Pomógł: 1528 razy
Posty: 4855
Wysłany: 13-03-2019, 11:58   

Spróbuj tak:
Kod:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim i&
    ost = Cells(Rows.Count, "M").End(xlUp).Row
        If Not Intersect(Target, Columns(13)) Is Nothing Then
            For Each cel In Target
            i = cel.Row
            If Target.Column <> 13 Then Exit Sub
                If VBA.Len(cel) > 0 Then
                    Range(Cells(2, "Y"), Cells(2, "BB")).Copy Cells(i, "Y")
                Else
                    Range(Cells(i, "Y"), Cells(i, "BB")).ClearContents
                End If
            Next cel
        End If
End Sub
ID posta: 364107 Skopiuj do schowka
 
 
kris82 
Starszy Forumowicz


Wersja: Win Office 2003
Posty: 34
Wysłany: 14-03-2019, 09:15   

Tadek, działa super, ogromne dzięki. Mam tylko jeszcze jedno pytanie, czy nie dałoby się gdzieś w makrze wyłączyć opcję odświeżania komórki po komórce aby przyspieszyć działanie kodu przy jednorazowym wklejeniu w kolumnę dużej ilości danych? Coś w rodzaju Application.ScreenUpdating=False/True, tyle że za bardzo to nie przyśpiesza działania kodu
ID posta: 364197 Skopiuj do schowka
 
 
Tadek
Excel Expert


Pomógł: 1528 razy
Posty: 4855
Wysłany: 14-03-2019, 10:02   

Spróbuj na początku kodu wstawić to:
Kod:
Application.Calculation = xlCalculationManual

a na końcu to:
Kod:
Application.Calculation = xlCalculationAutomatic
ID posta: 364200 Skopiuj do schowka
 
 
kris82 
Starszy Forumowicz


Wersja: Win Office 2003
Posty: 34
Wysłany: 15-03-2019, 23:24   

Jeszcze raz dzięki wielkie za pomoc, ostatecznie przerobiłem kod na wczytywanie wartości z kolumny M do array'a i teraz dopiero jestem zadowolony z szybkości działania skryptu. Poniżej kod dla potomnych

Kod:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim varray As Variant
Dim i As Long
ost = Cells(Rows.Count, "M").End(xlUp).Row
varray = Range("M1:M200").Value

    If Not Intersect(Target, Columns(13)) Is Nothing Then
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        For i = UBound(varray, 1) To LBound(varray, 1) Step -1
            If i < 4 Then
                Application.Calculation = xlCalculationAutomatic
                Application.ScreenUpdating = True
                Exit Sub
            End If
            If VBA.Len(varray(i, 1)) > 0 Then
                Range(Cells(2, "Y"), Cells(2, "BB")).Copy Cells(i, "Y")
            Else
                Range(Cells(i, "Y"), Cells(i, "BB")).ClearContents
            End If
        Next
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If
   
End Sub
ID posta: 364317 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.marketingNET.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