napisał: Trebor
postów: 1209
 umieszczony:
16 listopada 2007
20:24
|
|
Witaj i proszę tak jak umiem
Sub zbiorczy()
Dim a As Long
Dim zamknij As Boolean
'nie pokazuj na ekranie to co robi makro
Application.ScreenUpdating = False
'z tego skoroszytu w któryn jest makro i pierwszego arkusza - ma za zadanie skrócić pisanie kodu i jego szybsze wykonanie
With ThisWorkbook.Sheets(1)
'wyczyść zakres w pierwszej kolumnie od komórki A2 do ostatniej zapisanej
.Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp).Offset(0, 1)).ClearContents
'zakończ działania dla skoroszytu w którym jest makro i pierwszego arkusza
End With
'początek petli dla argmentów od 1 do 12 (tutaj chodzi o nazwy skorosztów
For a = 1 To 12
'przpisz do zmiennej zamknij - fałsz
zamknij = False
'włączenie obsługi błędów polegające na tym, że gdy wystąpi (błąd) makro ma przejść do następnęj instrukcji
On Error Resume Next
'aktywuj skoroszyt a.xls gdzie a przyjmuje wartość od 1 do 12
Workbooks(a & ".xls").Activate
'wyłączenie obsługi błędów
On Error GoTo 0
'jeśli nazwa skoroszytu pisana dużymi literami jest różna od a.XLS (a od 1 do 12), chodzi o to czy
'skoroszyt a.xls jest otwarty (aby nie otwierać go drugi raz) jeśli nie to go otwórz
If UCase(ActiveWorkbook.Name) <> a & ".XLS" Then
'otwarcie skoroszytu w trybie tylko do odczytu
Workbooks.Open Filename:=(ActiveWorkbook.Path & "\" & a & ".xls"), ReadOnly:=True
'poniższa zablokowana linia ukrywa skoroszyt a.xls
'Windows(a & ".xls").Visible = False
'zmiennej zamknij przypisujemy wartość true - chodzi o to że to makro otwarło skoroszyt a.xls i powinno go zamknąć
zamknij = True
'koniec warunku jeżeli
End If
'ze skoroszytu a.xls i jego pierwszego arkusza
With Workbooks(a & ".xls").Sheets(1)
'kopiowanie zakresu od A do ostatniej komórki w kolumnie A przesuniętej do B (coś w rodzaju A2:B10)
' do skoroszytu gdzie jest makro do pierwszego arkusza do kolumny A do komórki poniżej ostatniej zapisanej
.Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp).Offset(0, 1)).Copy ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
'koniec witha
End With
'jeśli zamknij ma wartość true to zamknij skoroszyt a.xls i tak na wszelki wypadek nie zapisuj w nim zmian
If zamknij = True Then Workbooks(a & ".xls").Close SaveChanges:=False
'następna wartośc dla a (tak do 12)
Next a
'skoroszyt w którym jest makro w arkuszu 1
With ThisWorkbook.Sheets(1)
'pętla for dla zmiennej a (drugi raz użycie tej samej zmiennej - podobno prawdziwi eksperci nie używają
' tej samej zmiennej dwa razy do różnych celów - ja nie jestem ekspertem więc mi wolno) tym razem od ostatniego wiersza
'zapisanego w kolumnie A do drugiego wiersza (step - krok ujemny)
For a = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
'jeśli komórka w wierszu a i kolumnie 1 jest pusta i komórka w wierszu a i kolumnie 2 jest pusta wtedy
'usuń komórki z wiersza a i kolumny 1 i 2 przesuwając komórki do góry
If .Cells(a, 1) = "" And .Cells(a, 2) = "" Then .Range(.Cells(a, 1), .Cells(a, 2)).Delete Shift:=xlUp
'nastepne a
Next
'koniec witha
End With
'włącz odświeżanie tego co dzieje się na ekranie
Application.ScreenUpdating = True
End Sub
Pozdrawiam |
|
|
napisał: fifas
postów: 12
umieszczony:
16 listopada 2007
18:31
|
|
a ja prosze o opis linijek z wyjasnieniem co dana czesc kodu oznacza i co robi.
Dzieki. |
|
|
napisał: fifas
postów: 12
umieszczony:
16 listopada 2007
18:30
|
|
Sub zbiorczy()
Dim a As Long
Dim zamknij As Boolean
Application.ScreenUpdating = False
With ThisWorkbook.Sheets(1)
.Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp).Offset(0, 1)).ClearContents
End With
For a = 1 To 12
zamknij = False
On Error Resume Next
Workbooks(a & ".xls").Activate
On Error GoTo 0
If UCase(ActiveWorkbook.Name) <> a & ".XLS" Then
Workbooks.Open Filename:=(ActiveWorkbook.Path & "\" & a & ".xls"), ReadOnly:=True
'Windows(a & ".xls").Visible = False
zamknij = True
End If
With Workbooks(a & ".xls").Sheets(1)
.Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp).Offset(0, 1)).Copy ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
If zamknij = True Then Workbooks(a & ".xls").Close SaveChanges:=False
Next a
With ThisWorkbook.Sheets(1)
For a = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If .Cells(a, 1) = "" And .Cells(a, 2) = "" Then .Range(.Cells(a, 1), .Cells(a, 2)).Delete Shift:=xlUp
Next
End With
Application.ScreenUpdating = True
End Sub |
|
|
napisał: fifas
postów: 12
umieszczony:
16 listopada 2007
18:29
|
|
Hejka,
Chodzi mi o makro kopiujace dane z pewnych arkuszy do jednego zbiorczego. Oto co napisales : |
|
|
napisał: Trebor
postów: 1209
umieszczony:
13 listopada 2007
21:24
|
|
Tak szczerze to ja się już pogubiłem. Napisz o jakie makro chodzi to spróbuje wstawić komentarze. Jeśli według mnie będą tam błędy to nie omieszkam o tym napisać, chociażby przyszło receznzować swoje dzieło 
Pozdrawiam |
|
|
napisał: fifas
postów: 12
umieszczony:
13 listopada 2007
19:21
|
|
Witam,
Trebor mialbys moze jeszcze sile wytlumaczyc (opisac poszczegolne skladniki kodu:co robi i po co ?) nowicjuszowi to makro ?
Pozdrawiam.
fifas |
|
|
napisał: Trebor
postów: 1209
umieszczony:
10 listopada 2007
09:07
|
|
| Cytat: Witam - temat segregacji nie daje mi spokoju postanowiłem więc do arkusza "13" wstawić :
Private Sub Worksheet_Change(ByVal Target As Range)
Worksheets("13").Activate
On Error Resume Next
If UCase(ActiveWorksheet.Name) <> "13" Then
Sheets("12").Columns("A:C").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End If
End Sub
Dane w tym arkuszu są segregowane ale w kolumnie A posegregowane i "wyświetlone" są wszystkie warości a w kolumnach B i C tylko 4 na 114 ???? Co zrobić by "wyświetlały" się wszystkie?
Sortowanie nie ukrywa wierszy, więc sądzę, że ukrycie jest pozostałością innych działań użytkownika bądź makra. Proponuję przed sortowaniem odkryć wszystkie wiersze.
Sub odkryj()
On Error Resume Next
Sheets("12").ShowAllData
Sheets("12").Rows.Hidden = False
On Error GoTo 0
End Sub
Pozdrawiam |
|
|
napisał: jast
postów: 10
umieszczony:
9 listopada 2007
09:48
|
|
Witam - temat segregacji nie daje mi spokoju postanowiłem więc do arkusza "13" wstawić :
Private Sub Worksheet_Change(ByVal Target As Range)
Worksheets("13").Activate
On Error Resume Next
If UCase(ActiveWorksheet.Name) <> "13" Then
Sheets("12").Columns("A:C").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End If
End Sub
Dane w tym arkuszu są segregowane ale w kolumnie A posegregowane i "wyświetlone" są wszystkie warości a w kolumnach B i C tylko 4 na 114 ???? Co zrobić by "wyświetlały" się wszystkie? |
|
|
napisał: Trebor
postów: 1209
umieszczony:
6 listopada 2007
22:08
|
|
Spróbujmy po fragmenciku
On Error Resume Next
Worksheets("13").Activate
If UCase(ActiveWorksheet.Name) <> "13" Then
Sheets("13").Columns("A:C").Select
Selection.ClearContents
End If
On Error GoTo 0
Włączasz obsługę błędów aby przkonać się czy istnieje arkusz o nazwie 13. Zaraz po Worksheets("13").Activate dałbym On Error GoTo 0 czyli wyłączył obsługę błędów.
Dalej, nie ma potrzeby stosować Ucase gdy w wyniku spodziewamy się liczby ( nie ma dużej i małej trzynastki, ActiveWorksheet.Name zamień na ActiveSheet.Name)
Teraz jeśli aktywnym arkuszem nie jest arkusz o nazwie 13, nie powinniśmy go wywoływać w następnej linii Sheets("13").Columns... ponieważ nic się nie zmieniło (dalej go nie ma). Jeśli jest, to oczywiście można wyczyścić kolumny AC ale nie ma konieczności ich zaznaczania. Wystarczy coś w rodzaju Sheets("13").Columns("A:C").ClearContents
Pozdrawiam |
|
|
napisał: jast
postów: 10
umieszczony:
6 listopada 2007
10:38
|
|
Dziękuję bardzo,
wszystkie Twoje propozycje wykorzystuję skrzętnie (do tej pory wszystko hula ale apetyt rośnie w miere poznawania nowych możliwości) więc zanim wszystko zgram razem i będę testował, potrzebuje pomocy chodzi mi o to by z wykorzystaniem poniższego kodu wstawione dane do arkusza "13" były następnie sortowane (A-Z)
oczywiście przy pomocy zakładki Narzędzia-Makro-stworzyłem sobie takie makro ale po włączeniu go do poniższego kodu ciągle wskazywane są jakieś błędy, z którymi nie mogę sobie poradzić.
A już szczytem marzeń byłoby by dane z pierwszych dwóch kolumn ulegały również scaleniu w jednej kolumnie np na zasadzie np. funkcji =A2&"/"&B2 a później posortowane A-Z. Czy jest to możliwe?
Pozdrawiam!
Private Sub Worksheet_Deactivate()
Dim wiersz As Long
Dim wynik As Long
Dim plik As String
plik = ActiveWorkbook.Name
On Error Resume Next
Worksheets("13").Activate
If UCase(ActiveWorksheet.Name) <> "13" Then
Sheets("13").Columns("A:C").Select
Selection.ClearContents
End If
On Error GoTo 0
With Workbooks("1.xls").Sheets("mroźnia")
For wiersz = 2 To .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
If .Cells(wiersz, 1) <> "" And .Cells(wiersz, 1) <> "" Then
wynik = 0
On Error Resume Next
wynik = WorksheetFunction.Match(plik & wiersz, Workbooks("1.xls").Sheets("13").Range(Workbooks("1.xls").Sheets("13").Cells(1, 3), Workbooks("1.xls").Sheets("13").Cells(Rows.Count, 3).End(xlUp)), 0)
On Error GoTo 0
If wynik = 0 Then
Workbooks("1.xls").Sheets("13").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = .Cells(wiersz, 1)
Workbooks("1.xls").Sheets("13").Cells(Rows.Count, 1).End(xlUp).Offset(0, 1) = .Cells(wiersz, 2)
Workbooks("1.xls").Sheets("13").Cells(Rows.Count, 1).End(xlUp).Offset(0, 2) = plik & wiersz
Else
If .Cells(wiersz, 1) <> Workbooks("1.xls").Sheets("13").Cells(wynik, 1) _
Or .Cells(wiersz, 2) <> Workbooks("1.xls").Sheets("13").Cells(wynik, 2) Then
Workbooks("1.xls").Sheets("13").Cells(wynik, 1) = .Cells(wiersz, 1)
Workbooks("1.xls").Sheets("13").Cells(wynik, 2) = .Cells(wiersz, 2)
End If
End If
End If
Next wiersz
End With
End Sub |
|
|
napisał: Trebor
postów: 1209
umieszczony:
5 listopada 2007
08:22
 edytowany:
5 listopada 2007
08:33
|
|
Po niewielkiej kosmetyce kod może mieć postać
Sub zbiorczy()
Dim a As Long
Dim zamknij As Boolean
Application.ScreenUpdating = False
With ThisWorkbook.Sheets(1)
.Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp).Offset(0, 1)).ClearContents
End With
For a = 1 To 12
zamknij = False
On Error Resume Next
Workbooks(a & ".xls").Activate
On Error GoTo 0
If UCase(ActiveWorkbook.Name) <> a & ".XLS" Then
Workbooks.Open Filename:=(ActiveWorkbook.Path & "\" & a & ".xls"), ReadOnly:=True
'Windows(a & ".xls").Visible = False
zamknij = True
End If
With Workbooks(a & ".xls").Sheets(1)
.Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp).Offset(0, 1)).Copy ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
If zamknij = True Then Workbooks(a & ".xls").Close SaveChanges:=False
Next a
With ThisWorkbook.Sheets(1)
For a = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If .Cells(a, 1) = "" And .Cells(a, 2) = "" Then .Range(.Cells(a, 1), .Cells(a, 2)).Delete Shift:=xlUp
Next
End With
Application.ScreenUpdating = True
End Sub
Jednak poprawki są raczej kosmetyczne. Jedna dotyczy miejsca czyszczenie (odbywało się w tym arkuszu w którym było uruchomione makro), drugie dotyczy zamrożenie ekranu aby nie było migotania ekranu.
Sprawdź czy w pliku 1.xls lub 2.xls (intuicyjnie )nie ma takich powtórzenia danych. Sprawdź całą kolumnę A (ctrl + strzałka)
Jeśli nie znajdziesz problemu zamieść na forum całe zestawienie plików.
Pozdrawiam |
|
|
napisał: jast
postów: 10
umieszczony:
4 listopada 2007
22:56
|
|
Cytat:Przeglądając jeszcze raz co jest do zrobienia i jak do tego dochodzimy sądzę że pewniejszym rozwiązaniem może być umieszczenie innego makra w pliku MR i przekopiowanie wszystkich informacji z dwunastu plików. Może to nie będzie szybsze ale bardzej odporne na różne błędy wyszukiwania poprawnych danych. Przykładowe makro może mieć postać:
Kod VBA:
Sub zbiorczy()
Dim a As Long
Dim zamknij As Boolean
Range(Range("A2"), Cells(Rows.Count, 1).End(xlUp).Offset(0, 1)).ClearContents
For a = 1 To 12
zamknij = False
On Error Resume Next
Workbooks(a & ".xls").Activate
On Error GoTo 0
If UCase(ActiveWorkbook.Name) <> a & ".XLS" Then
Workbooks.Open Filename:=(ActiveWorkbook.Path & "\" & a & ".xls"), ReadOnly:=True
'Windows(a & ".xls").Visible = False
zamknij = True
End If
With Workbooks(a & ".xls").Sheets(1)
.Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp).Offset(0, 1)).Copy ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
If zamknij = True Then Workbooks(a & ".xls").Close SaveChanges:=False
Next a
With ThisWorkbook.Sheets(1)
For a = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If .Cells(a, 1) = "" And .Cells(a, 2) = "" Then .Range(.Cells(a, 1), Cells(a, 2)).Delete Shift:=xlUp
Next
End With
End Sub
Jeśli takie rozwiązanie jest do przyjęcia to nad optymalizacją tego kodu możemy jeszcze popracować.
Własnie za miesiąc minie rok od napisania tego watku. Przedstawione makra zastosowałem i przetestowałem. Chciałbym jednak zastosować ostatnie zaproponowane przez ciebie makro ale po zainstalowaniu i uruchomieniu pojawia się pewien błąd z którym nie mogę sobie poradzić mianowicie mam dwanaście plików z których pewne wartości np z pliku nr 1 - aaaaa; z pliku nr 2-bbbbb; pliku nr z 3- ccccc;pliku nr z 4- dddddd itd gromadzone sa w pliku zbiorczym ale w pliku zbiorczym pojawia się coś takiego :
a
a
a
a
a
a
a
a
a
a
b
b
b
b
b
c
c
c
c
c
d
d
d
d
d
czyli dane zpliku nr 1 kopiowane sa do pliku zbiorczego dwukrotnie co zrobic by to zmienić ? Proszę o pomoc. |
|
|
napisał: jast
postów: 10
umieszczony:
25 grudnia 2006
18:43
|
|
| Przepraszam byłem bardzo zajety pracuję w branży która ma żniwa właśnie w okresie przedświątecznym Trebor życzę w pozostałe dni Zdrowych i Wesołych Świąt Bożego narodzenia. Do tematu n/w powrócę niebawem. |
|
|
napisał: Trebor
postów: 1209
umieszczony:
15 grudnia 2006
12:34
|
|
Przyczyn wolnego działania kodu może być wiele. Począwszy od słabego komputera przez miejsce przechowywania plików, dużo liczba formuł (lub ich zakres) w pliku MR.
Przeglądając jeszcze raz co jest do zrobienia i jak do tego dochodzimy sądzę że pewniejszym rozwiązaniem może być umieszczenie innego makra w pliku MR i przekopiowanie wszystkich informacji z dwunastu plików. Może to nie będzie szybsze ale bardzej odporne na różne błędy wyszukiwania poprawnych danych. Przykładowe makro może mieć postać:
Sub zbiorczy()
Dim a As Long
Dim zamknij As Boolean
Range(Range("A2"), Cells(Rows.Count, 1).End(xlUp).Offset(0, 1)).ClearContents
For a = 1 To 12
zamknij = False
On Error Resume Next
Workbooks(a & ".xls").Activate
On Error GoTo 0
If UCase(ActiveWorkbook.Name) <> a & ".XLS" Then
Workbooks.Open Filename:=(ActiveWorkbook.Path & "\" & a & ".xls"), ReadOnly:=True
'Windows(a & ".xls").Visible = False
zamknij = True
End If
With Workbooks(a & ".xls").Sheets(1)
.Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp).Offset(0, 1)).Copy ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
If zamknij = True Then Workbooks(a & ".xls").Close SaveChanges:=False
Next a
With ThisWorkbook.Sheets(1)
For a = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If .Cells(a, 1) = "" And .Cells(a, 2) = "" Then .Range(.Cells(a, 1), Cells(a, 2)).Delete Shift:=xlUp
Next
End With
End Sub
Jeśli takie rozwiązanie jest do przyjęcia to nad optymalizacją tego kodu możemy jeszcze popracować.
Pozdrawiam |
|
|
napisał: jast
postów: 10
umieszczony:
15 grudnia 2006
12:09
|
|
Witam
Makro działa, jestem pełen uznania, bardzo dziękuję - postaram się wykorzystać zaproponowane przykłady do modyfikacji moich plików.Oj będzie z tego duży pożytek.
Mam tylko jeszcze jedno pytanie - kopiowanie trwa bardzo wolno, jeden arkusz kopiuje się 15-20 min czy tak ma być? czy to mój komputer jest słaby (192 MB RAM)? czymożna na to coś poradzić? |
|
|
napisał: Trebor
postów: 1209
umieszczony:
13 grudnia 2006
15:42
|
|
Sprawdź czy takie makro będzie odpowiednie. Potrzebna jest jeszcze jedna kolumna do zapisania źródła danych wraz z nr wiersza. Założyłem że będzie to kolumna C.
Czy drugi punkt można załatwić sorowaniem?
Sub aa()
Dim wiersz As Long
Dim wynik As Long
Dim plik As String
plik = ActiveWorkbook.Name
On Error Resume Next
Windows("MR.xls").Activate
On Error GoTo 0
If UCase(ActiveWorkbook.Name) <> "MR.XLS" Then
Workbooks.Open (ActiveWorkbook.Path & "/MR.xls")
End If
'Windows("MR.xls").Visible = False ' odblokuj linię jeśli ma być niewidoczny
With Workbooks(plik).Sheets(1)
For wiersz = 2 To .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
If .Cells(wiersz, 1) <> "" And .Cells(wiersz, 1) <> "" Then
wynik = 0
On Error Resume Next
wynik = WorksheetFunction.Match(plik & wiersz, Workbooks("MR.xls").Sheets(1).Range(Workbooks("MR.xls").Sheets(1).Cells(1, 3), Workbooks("MR.xls").Sheets(1).Cells(Rows.Count, 3).End(xlUp)), 0)
On Error GoTo 0
If wynik = 0 Then
Workbooks("MR.xls").Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = .Cells(wiersz, 1)
Workbooks("MR.xls").Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(0, 1) = .Cells(wiersz, 2)
Workbooks("MR.xls").Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(0, 2) = plik & wiersz
Else
If .Cells(wiersz, 1) <> Workbooks("MR.xls").Sheets(1).Cells(wynik, 1) _
Or .Cells(wiersz, 2) <> Workbooks("MR.xls").Sheets(1).Cells(wynik, 2) Then
Workbooks("MR.xls").Sheets(1).Cells(wynik, 1) = .Cells(wiersz, 1)
Workbooks("MR.xls").Sheets(1).Cells(wynik, 2) = .Cells(wiersz, 2)
End If
End If
End If
Next wiersz
End With
'Workbooks("MR.xls").Close SaveChanges:=True
End Sub
Pozdrawiam |
|
|
napisał: jast
postów: 10
umieszczony:
13 grudnia 2006
13:17
|
|
Cytat "Przepraszam za sprawienie przykrości"
Nie ma sprawy duzi chłopcy nie płaczą.
Przetestowałem makro mam dwie uwagi - prośby:
1. Podczas kopiowania i wklejania 1.xls -> Mr.xls wszystko działa ale jeśli chcę z drugiego pliku np 2.xls skopiować do MR.xls to dane uprzednio skopiowane ( z 1.xls)i wklejone do MR.xls są kasowane i w ich miejsce wklejane są dane z 2.xls a mnie zależałoby by dane były wklejane pokoleji, gdyż w pliku tym (MR.xls) chcę gromadzić dane z 12 miesięcy czyli (1.xls-12.xls)
2. Potrzebuje także by w przypadku błędu lub uzupełnienia dotychczas skopiowanych i wpisanych danych można było skopiować i wpisać tylko te wiersze, które będą poprawiane lub dodawane tak by następowało przesunięcie dotychczasowej zawartości o tyle o ile wierszy dodano. To makro chyba tak robi ale ponieważ kasuje poprzedni zapis w MR.xls nie mogłem tego sprawdzić.
Przepraszam, że jestem takim marudą;)
Czapeczka do góry - pozdrawiam |
|
|
napisał: Trebor
postów: 1209
umieszczony:
12 grudnia 2006
12:18
|
|
Hej
Przepraszam za sprawienie przykrości :(
Ponieważ w dalszym ciągu nie wiem dokładnie jak ma odbywać się porównanie napisałem makro które coś tam robi. Potestuj aby sprawdzić co należy zmienić. Zakładam że obydwa pliki znajdują się w jednym folderze.
Sub aa()
Dim wiersz As Long
Dim wiersz2 As Long
On Error Resume Next
Windows("MR.xls").Activate
On Error GoTo 0
If UCase(ActiveWorkbook.Name) <> "MR.XLS" Then
Workbooks.Open (ActiveWorkbook.Path & "/MR.xls")
End If
'Windows("MR.xls").Visible = False ' odblokuj linię jeśli ma być widoczny
wiersz2 = 1
With Workbooks("1.xls").Sheets(1)
For wiersz = 2 To .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
If .Cells(wiersz, 1) <> "" And .Cells(wiersz, 1) <> "" Then
wiersz2 = wiersz2 + 1
If .Cells(wiersz, 1) <> Workbooks("MR.xls").Sheets(1).Cells(wiersz2, 1) _
Or .Cells(wiersz, 2) <> Workbooks("MR.xls").Sheets(1).Cells(wiersz2, 2) Then
Workbooks("MR.xls").Sheets(1).Cells(wiersz2, 1) = .Cells(wiersz, 1)
Workbooks("MR.xls").Sheets(1).Cells(wiersz2, 2) = .Cells(wiersz, 2)
End If
End If
Next wiersz
End With
'Workbooks("MR.xls").Close SaveChanges:=True
End Sub |
|
|
napisał: jast
postów: 10
umieszczony:
11 grudnia 2006
21:49
|
|
Cytat
"Nie sądzę, że zapomniałeś. Taka mała podpucha, ale niech Ci będzie."
Przykro mi, że tak to odebrałeś nie jestem cwaniaczkiem, ciężko pracuję miotając się między świadomością swojej niewiedzy a pokusą zrealizowania, dla mie, prawie nie osiągalnych celów. Ale ponieważ dajesz mi nadzieje więc precyzuje.
Przede wszystkim w kolumnach AiB plików źródłowych zapisy występują z przerwami między wierszami. W tym makro które mi podesłałeś kopiowane są kolumny z przerwami tak jak wpisane są dane a mnie chodzi o to by do kopiowania były brane tylko te wiersze które mają wpis i wklejane były do pliku docelowego w kolejności pierwszy wolny.Przy kolejnym kopiowaniu ( bo w pliku źródłowym będą się pojawiać nowe wpisy)dobrze by było by porównywało poprzednie wpisy i jeśli pojawi się nieścisłość przekopiować tylko tą nieścisłość lub nowy wpis.
Cytat
"Nie umiem bez otwierania pliku docelowego dopisać informacje. Co najwyżej może to być niewidoczne dla użytkownika."
Nie wiem co to oznacza - co najwyżej może być niewidoczne dla użytkownika - mnie chodzi o to bym nie musiał za każdym razem otwierać pliku MR.xls , ale jak się nie da to trudno.
Jeszcze raz dziękuję że mimo wątpliwości postanowiłeś mi pomóc.
Na koniec pozwól że podzielę się z Tobą moją maksymą "Jeśli chcesz kogoś wprowadzić w błąd powiedz mu prawdę - nigdy nie uwierzy"
Pozdrawiam |
|
|
napisał: Trebor
postów: 1209
umieszczony:
11 grudnia 2006
18:05
|
|
Cytat
"o co poprosiłem to mam, zainstalowałem i działa ale wybacz mi straszna ze mnie fujara zapomniałem o paru ważnych informacjach"
Koniec cytatu
Nie sądzę, że zapomniałeś. Taka mała podpucha, ale niech Ci będzie.
Czyli chcesz porównywać wszystkie niepuste komórki z pliku źródłowego z docelowym w kolumnie A i B wierszami i jeśli znajdzie choć jedną nieścisłość przekopiować wszysto jak leci?
Nie umiem bez otwierania pliku docelowego dopisać informacje. Co najwyżej może to być niewidoczne dla użytkownika.
Pozdrawiam |
|
|
wszystkich stron: 2
|
|
