Strona: [  << <   1   > >>  ]  z  1     
Autor Temat: Makro działa poprawnie tylko w trybie krokowym
Darek




Typ: neutral
Postów: 1
Zarejestrowany: May 2003
Makro działa poprawnie tylko w trybie krokowym

Cześć

Natkąłem się na nierozwiązywalny dla mnie problem.
Napisałem makro(zamieszczone poniżej), które działa tylko w trybie krokowym.
Przypuszczam, że w normalnym trybie niektóre instrukcje są wykonywane przed zakończeniem importu danych przez kwerendę.
Czy ktoś mógłby zasugerować jakieś rozwiązanie.
Z góry dziękuję.
Darek

Oto makro:

Dim FileToOpen As String
Sub SAT2()
Dim connstring, sqlstring, variable As String
Dim x, indeks As Variant
Dim Check
Check = True
    x = 1
    Do
    Call abrir
    If FileToOpen <> Empty Then
    Else: GoTo Fine
    End If
    connstring = "ODBC;DSN=Pliki programu Excel;DBQ=FileToOpen;DefaultDir=c:\WINDOWS\Pulpit\SAT"
    sqlstring = "SELECT * FROM " & "`" & FileToOpen & "`.`Arkusz1$` `Arkusz1$`"
    ActiveSheet.QueryTables.Add(Connection:=connstring, Destination:=Cells(x, 1), Sql:=sqlstring).Refresh
    If x > 1 Then
    Rows(x).delete Shift:=xlUp
    Else
    End If
    x = ActiveSheet.Columns(1).End(xlDown).Row + 1
    indeks = ActiveSheet.Columns(4).End(xlDown).Value
    If indeks >= 30 Then
    Check = False
    Exit Do
    End If
    Loop
Fine:    MsgBox "Koniec "
End Sub
Private Sub abrir()
ChDir "C:\WINDOWS\Pulpit\Sat"
FileToOpen = Application _
    .GetOpenFilename("Pliki Excel  (*.xls), *.xls", Title:="otwierane pliki", ButtonText:="otwieranie", MultiSelect:=False)
    MsgBox "Otwórz " & FileToOpen
End Sub



Darek


15-05-2003 11:58
Pokaż profil Darek  Wyślij email do Darek   
losmac
"profesorek"




Typ: neutral
Postów: 758
Zarejestrowany: May 2003
oto rozwiązanie...

Option Explicit 'wymuś deklarowanie zmiennych

Sub SAT2()
'zmiennych widzianych w calym module unikaj, bo
'wykorzystywane są przez cały czas działania programu
Dim FileToOpen As String
Dim strSQL As String, katalog As String, plik As String
Dim Counter As Long
Dim x As Long, indeks As Variant
Dim Check As Boolean

Check = True
Counter = 1
   
Do
    If Counter = 1 Then
    x = 1
    Else
    x = ActiveSheet.Columns(1).End(xlDown).Row + 1
    End If
    FileToOpen = DajPlik
    If FileToOpen = "" Then Exit Sub
    katalog = TnijString(FileToOpen)
    plik = katalog & TnijString(FileToOpen, , 1)
    strSQL = "SELECT aaa.*" & vbCrLf & "FROM `" & plik & "`.aaa aaa"
    'zarejestruj u siebie makro i sprawdź, czy DriverID jest taki sam
    'jeśli jest inny, to go zmień
    'resztę pozostaw bez zmian
    With ActiveSheet.QueryTables.Add( _
        Connection:="ODBC;DBQ=" & FileToOpen & ";" & _
        "DefaultDir=" & Left(katalog, Len(katalog) - 1) & ";" & _
        "Driver={Microsoft Excel Driver (*.xls)};DriverId=790;FIL=excel 8.0;" & _
        "MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;ReadOnly=1;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;", _
        Destination:=ActiveSheet.Range("A" & x))
        .Sql = strSQL
        '.PostText = True
        .FieldNames = IIf(x = 1, True, False)
        .RefreshStyle = xlInsertDeleteCells
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .RefreshOnFileOpen = False
        .HasAutoFormat = True
        .BackgroundQuery = True
        .SavePassword = True
        .SaveData = True
        .Refresh False
    End With

    'nie potrzebne dłużej, patrz linijka .FieldNames=
    'If x <> 1 Then Rows(x).Delete Shift:=xlUp
    indeks = ActiveSheet.Columns(4).End(xlDown).Value
    If indeks > 30 Then
        Check = False
        Exit Do
    End If
    Counter = Counter + 1
Loop

MsgBox "Dziękuję, to już koniec!", vbInformation, "Koniec "

End Sub

'=======================================================================================

Private Function DajPlik() As String
Dim strFileName As String

ChDir "C:\WINDOWS\Pulpit\Sat"
strFileName = Application.GetOpenFilename("Pliki Excel  (*.xls), *.xls", Title:="Wybierz plik...", MultiSelect:=False)
    'jesli wcisnieto 'Anuluj', okno dialogowe zwraca fałsz
    If strFileName = CStr(False) Then strFileName = ""
DajPlik = strFileName
End Function

'=======================================================================================

Function TnijString(strPrzeszukajTekst As String, Optional strZnajdzTekst As String = "\", Optional metoda As Long = 0) As String
Dim i As Long, dl As Long, poz As Long
Dim czyKoniec As Boolean

dl = Len(strPrzeszukajTekst)
czyKoniec = False

Do
    poz = InStr(poz + 1, strPrzeszukajTekst, strZnajdzTekst)
        If poz <> 0 Then
            i = poz
        Else
            czyKoniec = True
        End If
Loop Until czyKoniec

Select Case metoda
    Case 0 'katalog z ostatnim \
        TnijString = Left(strPrzeszukajTekst, i)
    Case 1 'nazwa pliku bez rozszerzenia
        dl = dl - i - 4
        TnijString = Mid(strPrzeszukajTekst, i + 1, dl)
    Case 2 '
        dl = dl - i
        TnijString = Mid(strPrzeszukajTekst, i + 1, dl)

End Select

End Function


_____________________________________________
POSTULATY STARUSZKA:
1) Ludzie, dbajcie o polszczyznę!!!
2) Ludzie, zadawajcie kompletne pytania, a nie rzucacie ochłapy i trzeba się domyślać o co chodzi!!!

Powodzenia
Maciej Łoś

22-05-2003 22:48
Pokaż profil losmac  Wyślij email do losmac   Odwiedź stronę losmac  
Wszystkich odpowiedzi: 1 :: Maxymalnie na stronę: 20
Strona: [  << <   1   > >>  ]  z  1