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: 67762 Skopiuj do schowka Wyszukiwanie danych i wstawienia do innego arkusza
Autor Wiadomość
GEO-XYZ 
Exceloholic


Wersja: Win Office 2013
Posty: 235
Wysłany: 06-04-2020, 19:32   Wyszukiwanie danych i wstawienia do innego arkusza

Witam,
Mam problem z makrem - generalnie nie rozumiem jeszcze dobrze działania procedur if for itp
Mam arkusz: work_dane - tak nazwany worksheet skad pobieram dane i mam arkusz work_obl_1 gdzie chce dane wkleić.
procedura działa tylko chciałbym aby dane do arkusza work_obl_1 były wklejane od komórki A6 w dół
A makro wkleja mi z takim samym wierszu jak jest w arkuszu work_dane - błąd leży w i oraz j nie wiem jak je zastosować w procedurze

Kod:


Sub kopiowanie_stanowisk_z_pikietami() ' kopiowanie danych do TACH_OBL_1, KOPIOWANIE WSPÓŁRZEDNYCH, USTAWIENIE AZYMUTU



Dim work_dane                       As Worksheet
Dim work_obl_1                      As Worksheet
Dim work_tach_dane                  As Worksheet


Dim i                               As Integer
Dim j                               As Integer



Set work_dane = Worksheets("TACH_PIKIETY")
Set work_obl_1 = Worksheets("TACH_OBL_1")
Set work_tach_dane = Worksheets("TACH_DANE")
 

ostatnia_pikieta = work_dane.Range("F1").Value


For i = 1 To ostatnia_pikieta
For j = 3 To ostatnia_pikieta + 3

If work_dane.Range("E" & i) = stanowisko Then
work_obl_1.Range("A" & i + 6) = work_dane.Range("A" & i).Value
work_obl_1.Range("F" & i + 6) = work_dane.Range("B" & i).Value
work_obl_1.Range("G" & i + 6) = work_dane.Range("C" & i).Value
work_obl_1.Range("H" & i + 6) = work_dane.Range("D" & i).Value

End If

Exit For
Exit For
Next j
Next i


End Sub


Próbowałem wstawiać j ale nic się wtedy nie dzieje jak jest z i takim jak w kodzie to przynajmniej pobiera dane ale wstawia z adresem komórki z arkusza work_dane.
A chciałbym aby dane zaczęły być wstawiane od wiersza A6 w dół.
_________________
XYZ
ID posta: 385077 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 613 razy
Posty: 3265
Wysłany: 06-04-2020, 19:40   

Załącz plik.
.
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
Chcesz precyzyjną odpowiedź - zadaj precyzyjne pytanie.
ID posta: 385078 Skopiuj do schowka
 
 
dm 
Excel Expert


Wersja: Win Office 2013
Pomógł: 454 razy
Posty: 1268
Wysłany: 06-04-2020, 20:30   

Spróbuj tak:
Kod:
j=6
For i = 1 To ostatnia_pikieta

If work_dane.Range("E" & i) = stanowisko Then
work_obl_1.Range("A" & j) = work_dane.Range("A" & i).Value
work_obl_1.Range("F" & j) = work_dane.Range("B" & i).Value
work_obl_1.Range("G" & j) = work_dane.Range("C" & i).Value
work_obl_1.Range("H" & j) = work_dane.Range("D" & i).Value
j=j+1
End If
Exit For
Next i

dm
ID posta: 385084 Skopiuj do schowka
 
 
Tajan


Pomógł: 4630 razy
Posty: 10245
Wysłany: 06-04-2020, 20:37   

dm, to
Kod:
 Exit For
to jest chyba zbędne bo w takim przypadku pętla wykona tylko jeden przebieg :-)
ID posta: 385085 Skopiuj do schowka
 
 
GEO-XYZ 
Exceloholic


Wersja: Win Office 2013
Posty: 235
Wysłany: 06-04-2020, 20:46   

umiejead,
Witam,
Przy większym problemie bym tak zrobił, ale tutaj były błędy wynikające ewidentnie z mojej niewiedzy i wam dm, Tajan, momentalnie się rzuciło w oczy co nie gra.
dm,
Nie działa - trzeba usunąć Exit for tak jak Tajan, napisał
Działa super.
Dziękować
_________________
XYZ
ID posta: 385087 Skopiuj do schowka
 
 
dm 
Excel Expert


Wersja: Win Office 2013
Pomógł: 454 razy
Posty: 1268
Wysłany: 06-04-2020, 21:21   

Oczywiście macie rację - skopiowałem Twój kod i nie usunąłem wszystkiego.
dm
ID posta: 385088 Skopiuj do schowka
 
 
GEO-XYZ 
Exceloholic


Wersja: Win Office 2013
Posty: 235
Wysłany: 06-04-2020, 22:57   

Witam,
Idzie jakoś przyśpieszyć kod?
Nie ukrywam przy np. 2000 danych idzie to dosyć wolno.
_________________
XYZ
ID posta: 385104 Skopiuj do schowka
 
 
ąćęłńóś
Excel Expert


Pomógł: 268 razy
Posty: 1285
Wysłany: 06-04-2020, 23:59   

Skąd właściwie pobierasz wartość zmiennej 'stanowisko' w tej procedurze powyżej, skoro wcześniej nigdzie ona nie występuje i nie ma żadnych przypisań ?
GEO-XYZ napisał/a:
Idzie jakoś przyśpieszyć kod?

Pewnie tak ... spróbuj z tablicami, do których zassiesz dane i obrobisz je w pamięci RAM.
ID posta: 385111 Skopiuj do schowka
 
 
GEO-XYZ 
Exceloholic


Wersja: Win Office 2013
Posty: 235
Wysłany: 07-04-2020, 09:52   

Witam,
Przepraszam faktycznie wkleiłem wcześniej tylko fragment kodu.
Czy można jakoś przyśpieszyć/wykonanie tej procedury?

Kod:

Option Explicit
Sub kopiowanie_stanowisk_z_pikietami() ' kopiowanie danych do TACH_OBL_1, KOPIOWANIE WSPÓŁRZEDNYCH, USTAWIENIE AZYMUTU

Dim ostatnie_stanowisko             As String
Dim stanowisko                      As String
Dim ostatnia_pikieta                As String
Dim parzyste                        As Integer

Dim work_dane                       As Worksheet
Dim work_obl_1                      As Worksheet
Dim work_tach_dane                  As Worksheet
Dim grady                           As String
Dim reszta                          As Double
Dim azymut                          As Double

Dim i                               As Integer
Dim j                               As Integer
Dim numer                           As String


Set work_dane = Worksheets("TACH_PIKIETY")
Set work_obl_1 = Worksheets("TACH_OBL_1")
Set work_tach_dane = Worksheets("TACH_DANE")
 
Call TACH_26_CZYSZCZENIE_OBL1.czyszczenie_obl1

grady = Round(Rnd * 398, 0)
reszta = Application.WorksheetFunction.Even(Application.WorksheetFunction.RandBetween(100, 9998))

work_tach_dane.Range("B1") = reszta / 10000 + grady
work_tach_dane.Range("B1").Copy
work_obl_1.Range("D1").PasteSpecial

stanowisko = work_obl_1.Range("B1").Value

ostatnia_pikieta = work_dane.Range("F1").Value

ostatnie_stanowisko = Worksheets("TACH_ST").Range("F1").Value


j = 6
For i = 1 To ostatnia_pikieta

If work_dane.Range("E" & i) = stanowisko Then
work_obl_1.Range("A" & j) = work_dane.Range("A" & i).Value
work_obl_1.Range("F" & j) = work_dane.Range("B" & i).Value
work_obl_1.Range("G" & j) = work_dane.Range("C" & i).Value
work_obl_1.Range("H" & j) = work_dane.Range("D" & i).Value
j = j + 1
End If

Next i



End Sub

Sub parzyste()

Debug.Print Application.Even(9998 * Rnd + 100)

End Sub
_________________
XYZ
ID posta: 385124 Skopiuj do schowka
 
 
dm 
Excel Expert


Wersja: Win Office 2013
Pomógł: 454 razy
Posty: 1268
Wysłany: 07-04-2020, 10:04   

Bez załącznika to tylko domysły, ale testuj.
Kod:
Sub kopiowanie_stanowisk_z_pikietami() ' kopiowanie danych do TACH_OBL_1, KOPIOWANIE WSPÓŁRZEDNYCH, USTAWIENIE AZYMUTU
Dim i                               As Long
Dim j                               As Long
Dim Lst                             As Long
Dim k                               As Long
Dim stanowisko                      As String
Dim dane
Dim wynik
Dim rws

stanowisko = Worksheets("TACH_OBL_1").Range("B1").Value
With Worksheets("TACH_PIKIETY")
    Lst = .Cells(Rows.Count, "A").End(xlUp).Row
    dane = .Range("A1:E" & Lst)
    ReDim wynik(1 To 4, 1 To UBound(dane))
    ReDim rws(1 To UBound(dane), 1 To 1)

    For i = 1 To UBound(dane)
        If dane(i, 5) = stanowisko Then
         k = k + 1
            For j = 1 To 4
                wynik(j, k) = dane(i, j)
            Next j
        End If
        rws(k, 1) = k
    Next i
    ReDim Preserve wynik(1 To 4, 1 To k)
    wynik = Application.Transpose(wynik)
End With
Stop
With Worksheets("TACH_OBL_1")
    .Range("A6").Resize(k, 1) = wynik
    .Range("F6").Resize(k, 3) = Application.Index(wynik, rws, Array(2, 3, 4))
End With

End Sub

dm
ID posta: 385126 Skopiuj do schowka
 
 
GEO-XYZ 
Exceloholic


Wersja: Win Office 2013
Posty: 235
Wysłany: 07-04-2020, 10:48   

dm,
Bład wyskakuje
Run-time error 9
Subscript out of range

zaznacza kod:

rws(k, 1) = k

Załączam oryginalny plik z moim kodem.
Zauważyłem jedną rzecz:
Na nowym , pustym pliku znacznie szybciej to chodzi niż na moim pliku gdzie mam pozostałe procedury i generalnie cały program. Czy jest możliwe czyszczenie pamięci w excel ?

pytanie_1.xlsm
Pobierz Plik ściągnięto 6 raz(y) 315.2 KB

_________________
XYZ
Ostatnio zmieniony przez GEO-XYZ 07-04-2020, 11:01, w całości zmieniany 1 raz  
ID posta: 385130 Skopiuj do schowka
 
 
dm 
Excel Expert


Wersja: Win Office 2013
Pomógł: 454 razy
Posty: 1268
Wysłany: 07-04-2020, 11:00   

U mnie działa, zobacz załącznik
dm

Ps Zwracam Twój załącznik, czy działa za wolno? (+ mała poprawka w kodzie)

AAA.xlsm
Pobierz Plik ściągnięto 10 raz(y) 20.63 KB

Kopia pytanie_1.xlsm
Pobierz Plik ściągnięto 13 raz(y) 319.62 KB

ID posta: 385131 Skopiuj do schowka
 
 
GEO-XYZ 
Exceloholic


Wersja: Win Office 2013
Posty: 235
Wysłany: 07-04-2020, 13:21   

dm,
Okej super działa.
Dziękować
_________________
XYZ
ID posta: 385154 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