activate, select

activate, select - VB/VBA/VBS - Programmation

Marsh Posté le 03-08-2007 à 16:03:03    

Bonjour,
je travaille sur deux classeurs.
Mon premier classeur est ouvert.
Dans ma macro j'ouvre le deuxième. Puis je fait référence à des cellules de ce deuxième classeur.
 
J'ai tenté des Activate ou Select sur mon deuxième classeur pourtant vba fait toujours référence aux cellules du premier.
 
 
Pour résumé,
 
 
1-'ouverture deuxième classeur
Dim appExcel As New Excel.Application
    Dim wBk As New Excel.Workbook
 
With appExcel
    .Visible = True
Set wBk = .Workbooks.Open(Filename:=Chemin & NomBase, ReadOnly:=False)
 
End With
 
 
2-'code qui référence à des cellules du deuxième classeur
 
 
Aidez moi SVP :sweat:

Reply

Marsh Posté le 03-08-2007 à 16:03:03   

Reply

Marsh Posté le 03-08-2007 à 16:20:43    

peux-tu donner la suite de ton ccode, car c'est à mon avis là qu'a lieu le pb ;)

Reply

Marsh Posté le 03-08-2007 à 16:25:20    

Merci de ton aide, je suis vraiment en galère.
 désolé il est assez long:
 
 
'crackage clé
 
Dim lngHandle As Long 'Manipulation de la bdr
Dim sCheminCle As String 'Chemin dans la bdr de la clé à ouvrir et à fermer
 
If Application.Version = "11.0" Then
    sCheminCle = "SoftwareMicrosoftOffice11.0WordOptions"
Else
    If Application.Version = "10.0" Then
        sCheminCle = "SoftwareMicrosoftOffice10.0WordOptions"
    End If
End If
 
If RegOpenKeyEx(HKEY_CURRENT_USER, sCheminCle, 0, KEY_ALL_ACCESS, lngHandle) = 0 Then
    If RegSetValueExLong(lngHandle, "SQLSecurityCheck", 0&, REG_DWORD, 0, 4) = 0 Then
        RegCloseKey (lngHandle)
    End If
End If
 
 
'ouverture word
 
Dim appWord As New Word.Application
    Dim docWord As New Word.Document
   
     
With appWord
    .Visible = True
Set docWord = .Documents.Open(Filename:=Chemin & NomFich, ReadOnly:=False)
    .Activate
 
End With
 
'signet tableaubat1
 
Dim b As Integer
b = Cells(1, 2).Value
 
If Cells(1, 4).Value = 1 Then
Else
If b = 7 Then
Range("A2:D9" ).Copy
Else
If b = 6 Then
Range("A2:D8" ).Copy
Else
If b = 5 Then
Range("A2:D7" ).Copy
Else
If b = 4 Then
Range("A2:D6" ).Copy
Else
If b = 3 Then
Range("A2:D5" ).Copy
Else
If b = 2 Then
Range("A2:D4" ).Copy
Else
Range("A2:D3" ).Copy
 
End If
End If
End If
End If
End If
End If
 
 
With appWord
.Selection.HomeKey Unit:=wdStory
.Selection.Goto What:=wdGoToBookmark, Name:="tableaubat1"
End With
 
 
appWord.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
 
End If
 
'signet tableaubat2 collage deuxieme tableau
 
 
If Cells(1, 4).Value = 1 Then
Else
If b = 7 Then
Range("G2:O9" ).Copy
Else
If b = 6 Then
Range("G2:O8" ).Copy
Else
If b = 5 Then
Range("G2:O7" ).Copy
Else
If b = 4 Then
Range("G2:O6" ).Copy
Else
If b = 3 Then
Range("G2:O5" ).Copy
Else
If b = 2 Then
Range("G2:O4" ).Copy
Else
Range("G2:O3" ).Copy
 
End If
End If
End If
End If
End If
End If
 
 
 
With appWord
.Selection.Goto What:=wdGoToBookmark, Name:="tableaubat2"
End With
 
 
appWord.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
 
End If
 
 
'autre signets
 
 
Dim h As Integer
 
For h = 323 To 650
 
Dim Texte As Variant
Texte = Cells(h, 21).Value
 
 
 
With appWord
 
If Not Texte = "" Then
 
 
.Selection.Goto What:=wdGoToBookmark, Name:="a" & h
.Selection.TypeText Text:=Texte
End If
End With
   
Next
 
'tableau deper
For i = 1 To 7
Dim a As Variant
a = Cells(22, 2).Value
If Not a < i Then
 
Range(Cells(4, 29 + 28 * (i - 1)), Cells(37, 37 + 28 * (i - 1))).Copy
 
With appWord
 
.Selection.Goto What:=wdGoToBookmark, Name:="deper" & i
 
.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
End With
 
End If
Next
 
'etiquette
 
For j = 1 To 7
 
If Not a < j Then
 
Range(Cells(43, 38 + 28 * (j - 1)), Cells(58, 47 + 28 * (j - 1))).Copy
With appWord
 
.Selection.Goto What:=wdGoToBookmark, Name:="etiquette" & j
 
 
.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
End With
End If
Next
 
'recapitulatif
If Cells(1, 4).Value = 1 Then
Else
If b = 7 Then
Range("R2:U10" ).Copy
Else
If b = 6 Then
Range("R2:U9" ).Copy
Else
If b = 5 Then
Range("R2:U8" ).Copy
Else
If b = 4 Then
Range("R2:U7" ).Copy
Else
If b = 3 Then
Range("R2:U6" ).Copy
Else
If b = 2 Then
Range("R2:U5" ).Copy
Else
Range("R2:U3" ).Copy
 
End If
End If
End If
End If
End If
End If
 
With appWord
.Selection.Goto What:=wdGoToBookmark, Name:="recapitulatif"
End With
 
 
appWord.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
 
End If
 
'chauffage
If Cells(1, 4).Value = 1 Then
Else
If b = 7 Then
Range("AU2:AV10" ).Copy
Else
If b = 6 Then
Range("AU2:AV9" ).Copy
Else
If b = 5 Then
Range("AU2:AV8" ).Copy
Else
If b = 4 Then
Range("AU2:AV7" ).Copy
Else
If b = 3 Then
Range("AU2:AV6" ).Copy
Else
If b = 2 Then
Range("AU2:AV5" ).Copy
Else
Range("AU2:AV3" ).Copy
 
End If
End If
End If
End If
End If
End If
 
With appWord
.Selection.Goto What:=wdGoToBookmark, Name:="chauffage"
End With
 
 
appWord.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
 
End If
'cout chauffage
If Cells(1, 4).Value = 1 Then
Else
If b = 7 Then
Range("X2:Y9" ).Copy
Else
If b = 6 Then
Range("X2:Y8" ).Copy
Else
If b = 5 Then
Range("X2:Y7" ).Copy
Else
If b = 4 Then
Range("X2:Y6" ).Copy
Else
If b = 3 Then
Range("X2:Y5" ).Copy
Else
If b = 2 Then
Range("X2:Y4" ).Copy
Else
Range("X2:Y3" ).Copy
 
End If
End If
End If
End If
End If
End If
 
With appWord
.Selection.Goto What:=wdGoToBookmark, Name:="coutchauffage"
End With
 
 
appWord.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
 
End If
 
'Gconso Ginst
 
Range("BW2:BY3" ).Copy
 
With appWord
.Selection.Goto What:=wdGoToBookmark, Name:="consoinst"
End With
 
 
appWord.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine, DisplayAsIcon:=False
 
'suppression espaces
 
With appWord
.Selection.Find.ClearFormatting
    With appWord.Selection.Find
        .Text = "  "
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
     .Selection.Find.Execute Replace:=wdReplaceAll
End With
 
With appWord
.Selection.Find.ClearFormatting
    With appWord.Selection.Find
        .Text = "  "
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
     .Selection.Find.Execute Replace:=wdReplaceAll
End With
 
With appWord
.Selection.Find.ClearFormatting
    With appWord.Selection.Find
        .Text = "  "
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
     .Selection.Find.Execute Replace:=wdReplaceAll
End With
 
With appWord
.Selection.Find.ClearFormatting
    With appWord.Selection.Find
        .Text = "  "
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
     .Selection.Find.Execute Replace:=wdReplaceAll
End With
'suppression lignes blanches
 
With appWord
.Selection.Find.Execute
    .Selection.Find.ClearFormatting
    .Selection.Find.Replacement.ClearFormatting
    With appWord.Selection.Find
        .Text = "^13{2;}" ' rechercher partout 2 ou + retour chariots
        .Replacement.Text = "^p" ' remplacer par un retour chariot
        .Forward = True
        .Wrap = wdFindContinue
        .MatchWildcards = True ' Usage des caractères génériques
    End With
    .Selection.Find.Execute Replace:=wdReplaceAll
     
End With
 
'publipostage
 
With docWord.MailMerge
        .OpenDataSource Name:=Chemin & NomBase, _
        Connection:="Driver={Microsoft Excel Driver (*.xls)};" & _
            "DBQ=" & Chemin & NomBase & "; ReadOnly=True;", _
            SQLStatement:="SELECT * FROM [données générales, PH$]"
             
    With docWord.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
 
            With .DataSource
                .FirstRecord = 1
                .LastRecord = 1
            End With
        .Execute Pause:=False
    End With
    End With
     
 'fermeture word
     
    Application.DisplayAlerts = False
  docWord.Close SaveChanges:=False
  Application.DisplayAlerts = True
 
 
'Ouvre la clé, supprime la valeur "SQLSecurityCheck" , ferme la clé (Retour à la normal)
If RegOpenKeyEx(HKEY_CURRENT_USER, sCheminCle, 0, KEY_ALL_ACCESS, lngHandle) = 0 Then
    If RegDeleteValue(lngHandle, "SQLSecurityCheck" ) = 0 Then
        RegCloseKey (lngHandle)
    End If
End If

Reply

Marsh Posté le 03-08-2007 à 16:27:11    

zoreye a écrit :


'crackage clé


on cautionne nous ?  :sweat:

Reply

Marsh Posté le 03-08-2007 à 16:30:42    

lol, rien de méchant.
C'est pour obliger word à répondre oui à la requête pour le publipostage.
Sinon il se met sur non par défaut.
J'ai peut-être pas tout compris ce qu'il se passe parce que je débute mais ne t'inquiète pas je ne fais rien de mal.

Reply

Marsh Posté le 03-08-2007 à 16:42:03    

ca va pa solutionner tin probleme mais c'est plus "joli" et surtout moins long
 
tu peux remplacer tes :
b = Cells(1, 2).Value
 
If Cells(1, 4).Value = 1 Then
Else
If b = 7 Then
Range("A2:D9" ).Copy
Else
If b = 6 Then
Range("A2:D8" ).Copy
Else
If b = 5 Then
Range("A2:D7" ).Copy
Else
If b = 4 Then
Range("A2:D6" ).Copy
Else
If b = 3 Then
Range("A2:D5" ).Copy
Else
If b = 2 Then
Range("A2:D4" ).Copy
Else
Range("A2:D3" ).Copy
 
End If
End If
End If
End If
End If
End If  
 
par
 
b = Cells(1, 2).Value
If Cells(1, 4).Value = 1 Then
Range(cells(2,1),cells(b+2,4 ).Copy
End If

Reply

Marsh Posté le 03-08-2007 à 16:47:25    

j'ai pas l'impression que tu indiques sur quels fichiers excels tu fais les copies.
 
tu devrais mettre
workbooks("fichier1.xls" ).worksheets("feuil1" ).range(cells(2,1),cells(8,4)).copy
 
ca devrait fonctionner

Reply

Marsh Posté le 03-08-2007 à 16:55:07    

Il me dit que l'indice n'appartient pas à la sélection.
J'ai essayé en rajoutant appExcel devant et pareil??

Reply

Marsh Posté le 03-08-2007 à 20:06:25    

juste au cas ou tu as remplacé fichier1.xls ; feuil1 par ce qu'il faut ou ta garder pareil ?
si c'est pas le cas à quel niveau apparait ce message ?

Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed