napisał: Trebor
postów: 1209
 umieszczony:
9 października 2012
21:07
|
|
| W kolumnie A masz Twoje skróty, które będą nazwami arkuszy. W kolumnie B w tym samym wierszu kryteria do wyszukania nazwy z kolumny A. Ot i cały pomysł. |
|
|
napisał: TomekPLWAW
postów: 3
umieszczony:
9 października 2012
19:29
 edytowany:
9 października 2012
19:32
|
|
Dzięki za podpowiedź ale chyba nie do końca rozumiem zapisku tego kodu, przecież i tak wywala błąd że arkusz nie może mieć w nazwie znaku "*".
A skoro w lista zawiera np Tom*k to arkusz o tej nazwie nie powstanie chyba że zamienić go na inny znak "_" gdy natrafi na *.
.Range("A1").AutoFilter Field:=1, Criteria1:=Sheets("Lista").Cells(i, "B")
sam zapis rozumiem jako że na zakresie A1 autofiltr sprawdza kryteria wyszukiwania zgodnie z arkuszem lista kolumna B wiersz zgodnie z parametrem i=2.
To w takim razie albo źle umieściłem samą linijkę albo tak jak powyżej problem tkwi w nazwie arkusza ze znakiem "*".
Czy dobrze rozumuje?
Sub dzielenie()
Dim imie As String, i As Integer
On Error GoTo errhandler
With Sheets("Lista")
i = 2
Do While .Cells(i, "A").Value <> ""
imie = .Cells(i, "A").Value
Sheets(imie).Cells.ClearContents
With Sheets("Dane1")
.Range("A1").AutoFilter Field:=1, Criteria1:=Sheets("Lista").Cells(i, "B")
'.Range("A1").AutoFilter Field:=1, Criteria1:=imie & "*"
.Range("A1").CurrentRegion.Copy Sheets(imie).Range("A1")
End With
i = i + 1
Loop
End With
Exit Sub
errhandler:
If Err.Number = 9 Then
Sheets.Add
ActiveSheet.Name = imie
Resume Next
End If
End Sub |
|
|
napisał: Trebor
postów: 1209
umieszczony:
5 października 2012
18:06
|
|
| W arkuszu lista w kolumnie B wpisz ciąg, który będziesz podawał w kryteriach dla filtru. Zmień odpowiednią linię w kodzie na: .Range("A1").AutoFilter Field:=1, Criteria1:=Sheets("Lista").Cells(i, "B") |
|
|
napisał: TomekPLWAW
postów: 3
umieszczony:
4 października 2012
17:41
edytowany:
4 października 2012
19:08
|
|
Wielkie dzięki działa poprawnie poza kilkoma wyjątkami. W liście mam parę wyjątków indeksów takich jak np "tom*k" co znaczy że powinien wyszukać wszystko co zaczyna się od "tom" i dalej zawiera "k". I tu się zaczynają schody..  |
|
|
napisał: Trebor
postów: 1209
umieszczony:
3 października 2012
20:31
|
|
Staraj się pisać kod tak, aby polecenia activate, select nie były potrzebne. Na początek przeglądnij poniższy kod.
Sub dzielenie()
Dim imie As String, i As Integer
On Error GoTo errhandler
With Sheets("Lista")
i = 2
Do While .Cells(i, "A").Value <> ""
imie = .Cells(i, "A").Value
Sheets(imie).Cells.ClearContents
With Sheets("Dane1")
.Range("A1").AutoFilter Field:=1, Criteria1:=imie & "*"
.Range("A1").CurrentRegion.Copy Sheets(imie).Range("A1")
End With
i = i + 1
Loop
End With
Exit Sub
errhandler:
If Err.Number = 9 Then
Sheets.Add
ActiveSheet.Name = imie
Resume Next
End If
End Sub |
|
|
napisał: TomekPLWAW
postów: 3
umieszczony:
3 października 2012
19:28
edytowany:
3 października 2012
19:32
|
|
Witam wszystkich.
Na wstępie sorry za błędy w kodzie ale jestem początkującym i czasami modyfikuję kod znaleziony gdzieś w sieci tak aby wykorzystać go dla własnych potrzeb więc nie zawsze jest on dopracowany.
Próbuje stworzyć makro które dzieliło by mi plik na arkusze na bazie danych zaczerpniętych z listy.
Zastanawiam się jak podmienić pobranie nazwy arkusza z kolumny G na kolumnę A z arkusza Lista!. Jak umieszczę listę w tym samym arkuszu np. w kolumnie H i podmienię G na H w kodzie to makro nawet działa.
Arkusze mi tworzy ale na bazie kolumny "A" a ja potrzebuję dokładnie wg listy (lista składa się z 3-5 pierwszych znaków całej komórki) macie jakiś pomysł ?
Option Explicit
Sub dzielenie()
Sheets("Dane1").Activate
On Error GoTo errhandler
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("G1"), Unique:=True
Dim i As Integer
i = 2
Dim imie As String
Do While Cells(i, "G").Value <> ""
imie = Cells(i, "G").Value
Sheets(imie).Activate
Cells.ClearContents
Sheets("Dane1").Activate
Range("A1").AutoFilter Field:=1, Criteria1:=imie
Range("A1").CurrentRegion.Copy Sheets(imie).Range("A1")
i = i + 1
Loop
Exit Sub
errhandler:
If Err.Number = 9 Then
Sheets.Add
ActiveSheet.Name = imie
Resume Next
End If
End Sub |
|
|
 wstecz 1 dalej  wszystkich stron: 1
|
Arkusz1.xlsm