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: 68959 Skopiuj do schowka Błędy podczas pracy z plikiem (onedrive)
Autor Wiadomość
wiorek
Fan Excela


Posty: 84
Wysłany: 23-09-2020, 17:29   Błędy podczas pracy z plikiem (onedrive)

Hej,

Posiadam w firmie plik współdzielony do użytku dla 5-10 osób.
Plik zapisany jest na teamsach lub onedrivie. Plik jest otwierany do edycji w aplikacji klasycznej z racji dużej ilości makr. Po włączeniu pliku wszystko jest ok, widać kto się loguje, kto jest w jakiej zakładce i co robi. Problem pojawia się w momencie kiedy pierwszy z pracowników wysyła dane na serwer ( plik zamienia arkusz na dane z txt, zapisuje jako txt, tworzy i wysyła emaila z załącznikiem ) - po tej operacji wyskakują błędy odnośnie konieczności ponownego zapisania, scalenia komórek itp .. Ponownie każdy z użytkowników musi uruchomić plik, inaczej nie widać kto co robi, gdzie pracuje - jest to o tyle ważne, że co około pół godziny jest aktualizacja ( w tym momencie automatyczna, ale z racji wykrzaczania, trzeba wykonywać te czynności manualnie ... ) a przy aktualizacji nowe linijki dodają się w nowym kolorze itp - więc to musi być. Dodatkowo gdy próbuje ppm na one drivie udostępnić zamienia nazwę skoroszytu dodaje (1),(2) itp.
Proszę o pomoc :-(

Screenshot 2020-09-23 122225.png
Plik ściągnięto 377 raz(y) 7.49 KB

ID posta: 392478 Skopiuj do schowka
 
 
wiorek
Fan Excela


Posty: 84
Wysłany: 23-09-2020, 17:33   

Przepraszam, ale nie mogę w jednej wiadomości dodać kilku załączników.

problem2.png
Plik ściągnięto 11 raz(y) 68.25 KB

ID posta: 392479 Skopiuj do schowka
 
 
Rafał B.
Exceloholic



Wersja: Win Office 2016
Pomógł: 35 razy
Posty: 237
Wysłany: 23-09-2020, 19:22   

Nie wiem czy coś poprawiono w najnowszych wersjach Office, moje doświadczenia ze współdzieleniem plików Excela (wersje 2016 i starsze) są fatalne- same dziwaczne problemy niezależnie od rodzaju chmury czy dysku. Może ktoś z bardziej doświadczonych użytkowników w tym względzie się wypowie. Jeśli niestety dalej lipa, to proponuję trzymanie danych w bazie zewnętrznej, a udostępnienie klientom osobnych kopii pliku (bo rozumiem, że "duża ilość makr" wyklucza arkusze Googla) .
ID posta: 392482 Skopiuj do schowka
 
 
marzatela 
Excel Expert



Zaproszone osoby: 309
Pomogła: 464 razy
Posty: 2560
Wysłany: 23-09-2020, 20:02   

Z mojego osobistego doświadczenia wynika, że udostępnione pliki z makrami mogą powodować problemy. Oczywiście wszystko zależy od tego, jakie to makra, ale mogą się pojawić problemy.
_________________
marzatela

http://www.szultaset.pl
ID posta: 392483 Skopiuj do schowka
 
 
wiorek
Fan Excela


Posty: 84
Wysłany: 23-09-2020, 22:26   

Ogólnie plik działa do momentu wysłania danych na serwer.
Jego działanie jest takie :
Pracownicy otrzymują plik z aktualnymi danymi za dany dzień, koordynator co godzine odświeża dane / dodaje nowe pozycje, które mają być automatycznie odświeżone w ich zakładkach - po aktualizacji wywala pierwsze błędy.
Następnie pracownicy po obrobieniu pliku wysyłają go na serwer - ich zakładka konwertuje się z wybranymi kolumnami na txt zapisuje jako załącznik i wysyła @ na serwer - po tej operacji 100% braku możliwości dalszej pracy.
Zgłosiłem problem do Microsoftu, zobaczymy jaka będzie odpowiedź. Mimo wszystko może ktoś ma sposób na jakieś obejście :)
ID posta: 392489 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3092 razy
Posty: 10242
Wysłany: 26-09-2020, 17:26   

Moim zdaniem istotnym jest co te makra robią. Należy pamiętać, że wielu rzeczy nie można robić w pliku udostępnionym. Sprawdź, czy makra próbują wykonać zabronione czynności. Istotnym jest także w jaki sposób dane są odświeżane (działanie koordynatora) oraz w jaki sposób przygotowywane, zapisywane i wysyłane są dane na serwer.
Bez konkretnych makr, ogólnie nie da się więcej doradzić.

Aaaa, i z jakiego typu udostępniania korzystasz? W starej wersji, czy w nowej?

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 392653 Skopiuj do schowka
 
 
wiorek
Fan Excela


Posty: 84
Wysłany: 28-09-2020, 22:14   

Artik napisał/a:

Sprawdź, czy makra próbują wykonać zabronione czynności. Istotnym jest także w jaki sposób dane są odświeżane (działanie koordynatora) oraz w jaki sposób przygotowywane, zapisywane i wysyłane są dane na serwer.
Bez konkretnych makr, ogólnie nie da się więcej doradzić.
Artik


Hej,
Przepraszam za późną odpowiedź. Bardzo dziękuję za poradę.
Po przeanalizowaniu linku podrzuconego przez Ciebie wydaje mi się, że nie wykonuje takich operacji.
Niestety nie mogę wrzuić całego pliku. Poniżej kod po którym występuje błąd :

Kod:
Sub przeslij()

kzbioru = Range("A500000").End(xlUp).Row

 Sheets("wyslij").Select
    Range("A:F").Select
    Selection.ClearContents
Sheets("baza").Select

Range("A3").Copy
    Range("AD6:AD" & kzbioru).Select
    ActiveSheet.Paste
   

    Range("A:A,AB:AB,AC:AC,AD:AD").Select
    Range("AB1").Activate
    Selection.Copy
    Sheets("wyslij").Select
    ActiveSheet.Paste
   
   
' cadis2 Makro
'
kzbioru = Range("A500000").End(xlUp).Row

'


    Range("E6").Select
    ActiveCell.FormulaR1C1 = "=RC[-4]&"";""&RC[-3]&"";""&RC[-2]&"";""&RC[-1]"
    Range("E6").Select
    Selection.Copy
        Range("E7:E" & kzbioru).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
   
    Columns("E:E").Select
    Selection.Copy
    Range("F1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("A:E").Select
    Range("E1").Activate
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
   
    Sheets("baza").Select
    Range("G1").Select
    Selection.Copy
    Sheets("wyslij").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Sheets("wyslij").Select
    Rows("2:5").Select
    Selection.Delete Shift:=xlUp

    Dim csvFiles(1 To 3) As String, i As Integer
    Dim wsName As Variant
    Dim OutApp As Object, OutMail As Object
   
    i = 0
    For Each wsName In Array("wyslij")     'nazwa arkusza
        i = i + 1
        csvFiles(i) = ThisWorkbook.Path & "\" & wsName & Format(Now(), "dd-mm-yyyyhhmmss") & ".txt"
        ThisWorkbook.Worksheets(wsName).Copy
        ActiveWorkbook.SaveAs csvFiles(i), FileFormat:=xlText
        ActiveWorkbook.Close False
    Next

    'Email
   
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = "podany adres serwera"     'ustaw odbiorce
        .CC = ""
        .BCC = ""
        .Subject = "txt"
        .Body = "Plik txt"
        .Attachments.Add csvFiles(1)
       
        .Send
    End With
    On Error GoTo 0
   
    Set OutMail = Nothing
    Set OutApp = Nothing
   
    'Usun po wyslaniu
   
    ' Kill csvFiles(1)
   
  Sheets("baza").Select
    Range("A6").Select
End Sub



Artik napisał/a:

Aaaa, i z jakiego typu udostępniania korzystasz? W starej wersji, czy w nowej?
Artik

Udostępnianie jest automatycznie włączone ( najnowszy office )
ID posta: 392781 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3092 razy
Posty: 10242
Wysłany: 28-09-2020, 23:07   

Po analizie makra dochodzę do wniosku, że prawdopodobną przyczyną problemów jest dwukrotne naruszenie struktury arkusza "wyślij" (nawet jednokrotne to już za dużo :-) ). W arkuszu tym usuwasz kolumny A:E a następnie wiersze 2:5.
Przebuduj makro tak, by nie usuwać wierszy/kolumn z arkusza.
Daj znać, czy pomogło.

A Twoje pierwotne makro, po oczyszczeniu, może wyglądać jak poniżej. Bez kupy Select-ów i niepotrzebnych kopiowań.
Kod:
Sub przeslij()
    Dim kzbioru     As Long
    Dim wsName      As Variant
    Dim OutApp As Object, OutMail As Object
    Dim wksActv     As Worksheet
    Dim wksWyslij   As Worksheet
    Dim wksBaza     As Worksheet
    Dim wkb         As Workbook
    Dim csvFile     As String


    Set wksActv = ActiveSheet
    Set wksWyslij = Worksheets("Wyslij")
    Set wksBaza = Worksheets("Baza")

    kzbioru = wksActv.Range("A" & Rows.Count).End(xlUp).Row

    wksWyslij.Range("A:F").ClearContents

    With wksBaza
        .Range("A3").Copy .Range("AD6:AD" & kzbioru)
        .Range("A:A,AB:AB,AC:AC,AD:AD").Copy wksWyslij.Range("A1")
    End With


    With wksWyslij
        kzbioru = .Range("A" & Rows.Count).End(xlUp).Row

        With .Range("E6:E" & kzbioru)
            .FormulaR1C1 = "=RC[-4]&"";""&RC[-3]&"";""&RC[-2]&"";""&RC[-1]"
            .Value = .Value
        End With

        .Range("F1:F" & kzbioru).Value = .Range("E1:E" & kzbioru).Value

        .Columns("A:E").Delete Shift:=xlToLeft

        .Range("A1").Value = wksBaza.Range("G1").Value
        .Rows("2:5").Delete Shift:=xlUp

        csvFile = ThisWorkbook.Path & "\" & "wyslij" & Format(Now(), "dd-mm-yyyyhhmmss") & ".txt"

        .Copy
    End With


    Set wkb = ActiveWorkbook

    wkb.SaveAs Filename:=csvFile, FileFormat:=xlText
    wkb.Close False


    'Email

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = "podany adres serwera"     'ustaw odbiorce
        .CC = ""
        .BCC = ""
        .Subject = "txt"
        .Body = "Plik txt"
        .Attachments.Add csvFile

        .Send
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

    'Usun po wyslaniu
    ' Kill csvFiles(1)

    With wksBaza
        .Select
        .Range("A6").Select
    End With
End Sub


Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 392783 Skopiuj do schowka
 
 
Rafał B.
Exceloholic



Wersja: Win Office 2016
Pomógł: 35 razy
Posty: 237
Wysłany: 29-09-2020, 17:45   

Pozwolę sobie wtrącić między wódkę a zakąskę ;)
Jeśli zależy nam na "późnym wiązaniu" i jednoczesnie niezawodności, to na linijkę
Cytat:
Set OutApp = CreateObject("Outlook.Application")

trzeba dać poprawkę opisaną m.in. tutaj:
www.rondebruin.nl
W innym przypadku to tylko kwestia czasu wystąpienia dziwnych problemów. Pewnie @Oshon mógłby więcej na ten temat powiedzieć; po prostu Outlook zachowuje się inaczej pod tym względem niż reszta komponentów pakietu Office.
ID posta: 392817 Skopiuj do schowka
 
 
wiorek
Fan Excela


Posty: 84
Wysłany: 30-09-2020, 11:58   

Rafał B. napisał/a:
Pozwolę sobie wtrącić między wódkę a zakąskę ;)
Jeśli zależy nam na "późnym wiązaniu" i jednoczesnie niezawodności, to na linijkę
Cytat:
Set OutApp = CreateObject("Outlook.Application")

trzeba dać poprawkę opisaną m.in. tutaj:


Dzięki za info zaraz się z nim zapoznam ;-)
Jeżeli @Oshon ma ochotę coś dodać, bardzo poproszę :)

Na ten moment działa, ale wyrzuca wszystkim excela, jak używam poniższych procedur.
Uruchamiam je używając call. Wszystkie są takie same, z tą różnicą, że 1 i ostatnia mają dodane dodatkowe wyciągane filtrowanie w bazie.
Plus dodatkowo wywala nowy błąd o nowej bazie danych ?
Jeżeli znajdziesz chwilę Artik, bardzo proszę o pomoc.


Kod:
Sub aktualizuj()
Call aktualizacja1
Call aktualizacja2
Call aktualizacja3
Call aktualizacja4
Call aktualizacja5

End Sub




Kod:

Sub aktualizacja1()

Application.ScreenUpdating = False ' nie pokazuje w arkuszu wykonywanie operacji
Application.DisplayAlerts = False ' wy?acza pytania o potwierdzenia

ActiveSheet.Range("$A$10:$BC$10933").AutoFilter Field:=10, Criteria1:=Array _
        ("klient1", "klient2 ", _
"klient3", "klient4", _
        "klient5", _
        "klient6"), Operator:= _
        xlFilterValues
    Range("O1:O10000").Select
     Selection.Replace What:="839", Replacement:="841", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    ActiveSheet.Range("$A$10:$BC$10933").AutoFilter Field:=10

Dim i&, ile&, ost&, ost2&, k&, ostK&, ostK2
Dim zakres As Range

    With Sheets("tomek")
        Set zakres = .Range("A6:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        ost2 = .Cells(Rows.Count, "A").End(xlUp).Row
        ostK2 = .Cells(6, Columns.Count).End(xlToLeft).Column
        If ost2 > 6 Then
            .Range(.Cells(7, 1), .Cells(ost2, ostK2)).Interior.Color = xlNone
        End If
    End With
   
    With Sheets("Baza")
        ost = .Cells(Rows.Count, "A").End(xlUp).Row
        ostK = .Cells(6, Columns.Count).End(xlToLeft).Column
        For i = 7 To ost
            ile = Application.CountIf(zakres, .Cells(i, 1))
            If ile = 0 And .Cells(i, 15).Value = "829" Or ile = 0 And .Cells(i, 15).Value = "830" Or ile = 0 And .Cells(i, 15).Value = "841" Or ile = 0 And .Cells(i, 15).Value = "842" Or ile = 0 And .Cells(i, 15).Value = "843" Or ile = 0 And .Cells(i, 15).Value = "844" Or ile = 0 And .Cells(i, 15).Value = "861" Then
                With Sheets("101482")
                    ost2 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                    .Cells(ost2, 1).Value = Sheets("Baza").Cells(i, 1).Value
                    .Cells(ost2, 2).Value = Sheets("Baza").Cells(i, 2).Value
                    For k = 3 To ostK
                        .Cells(ost2, k).Value = Sheets("Baza").Cells(i, k).Value
                    Next
                    .Range(.Cells(ost2, 1), .Cells(ost2, ostK)).Interior.ColorIndex = 35
                End With
            End If
        Next
    End With
   
Sheets("tomek").Select
   
    kzbioru = Range("A500000").End(xlUp).Row
    Range("AE1").Copy
    Range("AB6:AB" & kzbioru).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
Range("A5").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.AutoFilter
    Range("A6").Select
Sheets("Baza").Select
     
End Sub


Sub aktualizacja2()


Application.ScreenUpdating = False ' nie pokazuje w arkuszu wykonywanie operacji
Application.DisplayAlerts = False ' wy?acza pytania o potwierdzenia

Dim i&, ile&, ost&, ost2&, k&, ostK&, ostK2
Dim zakres As Range

    With Sheets("andrzej")
        Set zakres = .Range("A6:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        ost2 = .Cells(Rows.Count, "A").End(xlUp).Row
        ostK2 = .Cells(6, Columns.Count).End(xlToLeft).Column
        If ost2 > 6 Then
            .Range(.Cells(7, 1), .Cells(ost2, ostK2)).Interior.Color = xlNone
        End If
    End With
   
    With Sheets("Baza")
        ost = .Cells(Rows.Count, "A").End(xlUp).Row
        ostK = .Cells(6, Columns.Count).End(xlToLeft).Column
        For i = 7 To ost
            ile = Application.CountIf(zakres, .Cells(i, 1))
            If ile = 0 And .Cells(i, 15).Value = "831" Or ile = 0 And .Cells(i, 15).Value = "832" Or ile = 0 And .Cells(i, 15).Value = "897" Or ile = 0 And .Cells(i, 15).Value = "980" Then
                With Sheets("andrzej")
                    ost2 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                    .Cells(ost2, 1).Value = Sheets("Baza").Cells(i, 1).Value
                    .Cells(ost2, 2).Value = Sheets("Baza").Cells(i, 2).Value
                    For k = 3 To ostK
                        .Cells(ost2, k).Value = Sheets("Baza").Cells(i, k).Value
                    Next
                    .Range(.Cells(ost2, 1), .Cells(ost2, ostK)).Interior.ColorIndex = 35
                End With
            End If
        Next
    End With
   
Sheets("andrzej").Select
   
    kzbioru = Range("A500000").End(xlUp).Row
    Range("AE1").Copy
    Range("AB6:AB" & kzbioru).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
Range("A5").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.AutoFilter
    Range("A6").Select
Sheets("Baza").Select

End Sub


Sub aktualizacja3()


Application.ScreenUpdating = False ' nie pokazuje w arkuszu wykonywanie operacji
Application.DisplayAlerts = False ' wy?acza pytania o potwierdzenia

Dim i&, ile&, ost&, ost2&, k&, ostK&, ostK2
Dim zakres As Range

    With Sheets("hania")
        Set zakres = .Range("A6:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        ost2 = .Cells(Rows.Count, "A").End(xlUp).Row
        ostK2 = .Cells(6, Columns.Count).End(xlToLeft).Column
        If ost2 > 6 Then
            .Range(.Cells(7, 1), .Cells(ost2, ostK2)).Interior.Color = xlNone
        End If
    End With
   
    With Sheets("Baza")
        ost = .Cells(Rows.Count, "A").End(xlUp).Row
        ostK = .Cells(6, Columns.Count).End(xlToLeft).Column
        For i = 7 To ost
            ile = Application.CountIf(zakres, .Cells(i, 1))
            If ile = 0 And .Cells(i, 15).Value = "834" Or ile = 0 And .Cells(i, 15).Value = "835" Or ile = 0 And .Cells(i, 15).Value = "845" Or ile = 0 And .Cells(i, 15).Value = "851" Or ile = 0 And .Cells(i, 15).Value = "856" Or ile = 0 And .Cells(i, 15).Value = "857" Then
                With Sheets("hania")
                    ost2 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                    .Cells(ost2, 1).Value = Sheets("Baza").Cells(i, 1).Value
                    .Cells(ost2, 2).Value = Sheets("Baza").Cells(i, 2).Value
                    For k = 3 To ostK
                        .Cells(ost2, k).Value = Sheets("Baza").Cells(i, k).Value
                    Next
                    .Range(.Cells(ost2, 1), .Cells(ost2, ostK)).Interior.ColorIndex = 35
                End With
            End If
        Next
    End With
   
Sheets("hania").Select
   
    kzbioru = Range("A500000").End(xlUp).Row
    Range("AE1").Copy
    Range("AB6:AB" & kzbioru).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
Range("A5").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.AutoFilter
    Range("A6").Select
Sheets("Baza").Select

End Sub


Sub aktualizacja4()


Application.ScreenUpdating = False ' nie pokazuje w arkuszu wykonywanie operacji
Application.DisplayAlerts = False ' wy?acza pytania o potwierdzenia

Dim i&, ile&, ost&, ost2&, k&, ostK&, ostK2
Dim zakres As Range

    With Sheets("basia")
        Set zakres = .Range("A6:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        ost2 = .Cells(Rows.Count, "A").End(xlUp).Row
        ostK2 = .Cells(6, Columns.Count).End(xlToLeft).Column
        If ost2 > 6 Then
            .Range(.Cells(7, 1), .Cells(ost2, ostK2)).Interior.Color = xlNone
        End If
    End With
   
    With Sheets("Baza")
        ost = .Cells(Rows.Count, "A").End(xlUp).Row
        ostK = .Cells(6, Columns.Count).End(xlToLeft).Column
        For i = 7 To ost
            ile = Application.CountIf(zakres, .Cells(i, 1))
            If ile = 0 And .Cells(i, 15).Value = "833" Or ile = 0 And .Cells(i, 15).Value = "836" Then
                With Sheets("basia")
                    ost2 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                    .Cells(ost2, 1).Value = Sheets("Baza").Cells(i, 1).Value
                    .Cells(ost2, 2).Value = Sheets("Baza").Cells(i, 2).Value
                    For k = 3 To ostK
                        .Cells(ost2, k).Value = Sheets("Baza").Cells(i, k).Value
                    Next
                    .Range(.Cells(ost2, 1), .Cells(ost2, ostK)).Interior.ColorIndex = 35
                End With
            End If
        Next
    End With
   
Sheets("basia").Select
   
    kzbioru = Range("A500000").End(xlUp).Row
    Range("AE1").Copy
    Range("AB6:AB" & kzbioru).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
Range("A5").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.AutoFilter
    Range("A6").Select
Sheets("Baza").Select

End Sub


Sub aktualizacja5()

Application.ScreenUpdating = False ' nie pokazuje w arkuszu wykonywanie operacji
Application.DisplayAlerts = False ' wy?acza pytania o potwierdzenia

ActiveSheet.Range("$A$10:$BC$10933").AutoFilter Field:=10, Criteria1:=Array _
        ("klient7", "klient8 ", _
"klient9", "klient10", _
        "klient11 ", _
        "klient12"), Operator:= _
        xlFilterValues
    Range("O1:O10000").Select
     Selection.Replace What:="830", Replacement:="838", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    ActiveSheet.Range("$A$10:$BC$10933").AutoFilter Field:=10

Dim i&, ile&, ost&, ost2&, k&, ostK&, ostK2
Dim zakres As Range

    With Sheets("franek")
        Set zakres = .Range("A6:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        ost2 = .Cells(Rows.Count, "A").End(xlUp).Row
        ostK2 = .Cells(6, Columns.Count).End(xlToLeft).Column
        If ost2 > 6 Then
            .Range(.Cells(7, 1), .Cells(ost2, ostK2)).Interior.Color = xlNone
        End If
    End With
   
    With Sheets("Baza")
        ost = .Cells(Rows.Count, "A").End(xlUp).Row
        ostK = .Cells(6, Columns.Count).End(xlToLeft).Column
        For i = 7 To ost
            ile = Application.CountIf(zakres, .Cells(i, 1))
            If ile = 0 And .Cells(i, 15).Value = "838" Or ile = 0 And .Cells(i, 15).Value = "840" Or ile = 0 And .Cells(i, 15).Value = "847" Or ile = 0 And .Cells(i, 15).Value = "848" Or ile = 0 And .Cells(i, 15).Value = "849" Or ile = 0 And .Cells(i, 15).Value = "850" Or ile = 0 And .Cells(i, 15).Value = "837" Or ile = 0 And .Cells(i, 15).Value = "839" Or ile = 0 And .Cells(i, 15).Value = "846" Then
                With Sheets("franek")
                    ost2 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                    .Cells(ost2, 1).Value = Sheets("Baza").Cells(i, 1).Value
                    .Cells(ost2, 2).Value = Sheets("Baza").Cells(i, 2).Value
                    For k = 3 To ostK
                        .Cells(ost2, k).Value = Sheets("Baza").Cells(i, k).Value
                    Next
                    .Range(.Cells(ost2, 1), .Cells(ost2, ostK)).Interior.ColorIndex = 35
                End With
            End If
        Next
    End With
   
Sheets("franek").Select
   
    kzbioru = Range("A500000").End(xlUp).Row
    Range("AE1").Copy
    Range("AB6:AB" & kzbioru).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
Range("A5").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.AutoFilter
    Range("A6").Select
Sheets("Baza").Select
   
   
   
End Sub


nowyblad.png
Plik ściągnięto 219 raz(y) 5.35 KB

ID posta: 392870 Skopiuj do schowka
 
 
Rafał B.
Exceloholic



Wersja: Win Office 2016
Pomógł: 35 razy
Posty: 237
Wysłany: 30-09-2020, 16:54   

Dlaczego zignorowałeś poniższą wskazówkę?
Artik napisał/a:
A Twoje pierwotne makro, po oczyszczeniu, może wyglądać jak poniżej.
Bez kupy Select-ów i niepotrzebnych kopiowań.

Nie zastanowiło Cię o jakie oczyszczenie chodzi? Przecież taki kod, jak wkleiłeś to jeden wielki bałagan i wywalać się może losowo raz na kilkaset razy. Przeanalizuj przykład Artika, wyguglaj "how to avoid select vba", poświęć godzinę na zrozumienie i oszczędź sobie i osobom Ci pomagającym ogrom czasu w przyszłości.
ID posta: 392892 Skopiuj do schowka
 
 
wiorek
Fan Excela


Posty: 84
Wysłany: 30-09-2020, 18:23   

Rafał B. napisał/a:
Dlaczego zignorowałeś poniższą wskazówkę?


Przecież powyższe makro jest innym niż to, które było pierwotnie wskazane.
To co dla niektórych jest śmietnikiem, dla innych może być wynikiem długiej pracy ;-)
ID posta: 392893 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