napisał:  admin
postów: 613
 umieszczony:
3 października 2007
19:34
 edytowany:
3 października 2007
19:35
|
|
| Używaj znaczników vbcode. |
|
|
napisał: 0jack0
postów: 24
umieszczony:
3 października 2007
18:21
|
|
Witam wszystkich wymiataczy VBA po wakacyjnej przerwie.
Mam dwa problemy które niejestem w stanie się z nimi uporać
Po pierwsze
Posiadam dwa kody VBA, które chciałbym połączyć w jedno makro.
Proszę propozycję złączenia kodów zamieszczonych poniżej w jedną całość.
KOD 1
Sub Podziel()
Dim zakres As Integer
Dim w As Long
zakres = 1
With ActiveSheet
LastRow = .UsedRange.Rows.Count
For w = 2 To LastRow + 1
If .Cells(w, 7).Value <> .Cells(w - 1, 7).Value Then
.Range(.Cells(zakres, 1), .Cells(w - 1, 35)).Copy
Sheets.Add
Cells(2, 1).PasteSpecial
ActiveSheet.Name = Cells(2, 7).Value
zakres = w
End If
Next w
End With
End Sub
KOD 2
Sub Zapisz()
Dim LastRow As Long
Dim Arkusz As Worksheet
Dim CDrive As String
Dim CDir As String
On Error GoTo Zapisz_Error
With Application
'wyłączenie alertów - potrzebne, gdy nadpisywany jest plik
.DisplayAlerts = False
'wyłaczenie odświeżania ekranu
.ScreenUpdating = False
End With
'zapamiętanie aktualnych: dysku i ścieżki
CDir = CurDir
CDrive = Left(CDir, 1)
'zmiana dysku i ścieżki
ChDrive "D"
ChDir "d:\temp\"
For Each Arkusz In ActiveWorkbook.Worksheets
LastRow = Arkusz.UsedRange.Rows.Count
With Arkusz
.Range(.Cells(1, 1), .Cells(LastRow, 35)).Copy
End With
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
With ActiveWorkbook
.SaveAs Filename:=Cells(2, 7).Value & ".xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
.Close
End With
Next Arkusz
End_Zapisz:
'przywrócenie oryginalnych: dysku i ścieżki
ChDrive CDrive
ChDir CDir
'przywrócenie alertów i odświeżania
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
On Error GoTo 0
Exit Sub
Zapisz_Error:
Stop
Select Case Err.Number
Case 68
MsgBox "Na tym komputerze nie ma dysku ""D:""!" & vbCr & vbCr & _
"Działanie programu zostanie przerwane!", vbCritical, "Błąd"
Resume End_Zapisz
Case 76
MsgBox "Brak ścieżki ""D:\temp\""" & vbCr & _
"Proszę utworzyć katalog w powyższej lokalizacji." & vbCr & vbCr & _
"Działanie programu zostanie przerwane!", vbCritical, "Błąd"
Resume End_Zapisz
Case 1004
'ponieważ błędów nr 1004 może być kilka
'przez treść błędu dowiaduję się o jaki chodzi
If Err.Description Like "*Method*SaveAs*" Then
MsgBox "Brak nazwy w komórce G2 w arkuszu: " & Arkusz.Name & vbCr & _
"Proszę wpisać nazwę w powyższej lokalizacji." & vbCr & vbCr & _
"Działanie programu zostanie przerwane!", vbCritical, "Błąd"
Else 'jeśli jest inna treść błędu nr 1004
MsgBox "Prawdopodobną przyczyną błędu jest brak nazwy w komórce G2 w arkuszu: " _
& Arkusz.Name & vbCr & _
"Jeśli tak jest, proszę wpisać nazwę w powyższej lokalizacji." & vbCr & vbCr & _
"Lecz przyczyną błędu może być też inna, bliżej nie określona sytuacja." & vbCr & _
"Działanie programu zostanie przerwane!", vbCritical, "Błąd"
End If
Case Else 'inny nieprzewidziany błąd
MsgBox "Błąd nr " & Err.Number & _
"; Treść błędu: " & _
"(" & Err.Description & ")"
End Select
'zamknięcie niepotrzebnego skoroszytu (nowego)
With ActiveWorkbook
.Saved = True
.Close
End With
If Err.Number = 1004 Then
'aktywacja arkusza i komórki w której brakuje nazwy
Arkusz.Activate
Cells(2, 7).Select
End If
Resume End_Zapisz
End Sub
Po drugie
Kod zamieszczony jako drugi z przy większych ilościach danych kończy się błędem "overlow". Jedyne wyjście to podzielić plik na dwa mniejsze.
czekam na propozycję ulepszenia tego makro.
pozdro |
|
|
 wstecz 1 dalej  wszystkich stron: 1
|
