transfert ne se fait pas

[PHILIP]

Bonsoir à tous,

J'ai un souci dans l'ecriture d'un code qui ne realise pas ce que je voudrais
j'ai un classeur 7 qui a en colonne c (c3:c15)des données concernant un stock Ce classeur est actualisé tous les jours . Ce stock je souhaiterai le transferer dans la colonne adequate du classeur 6 (stock mensuel). pour ce faire je prends la date du classeur 7 (c'est une aujourd'hui)qui se trouve en B1 je recherche la même date du mois en cours dans la ligne 1 du classeur 6 (de C3 à AG1 suivant le mois) et je colle les données à la suite de la date dans la même colonne
voici le code qui ne donne pas le résultat souhaité (rien ne se transfert

Sub actua()
    Dim wb1 As Workbook, wb2 As Workbook
    Set wb1 = Workbooks("classeur7.xls")
    Set wb2 = Workbooks("classeur6.xls")
    Dim plage As Range, c As Range
    Dim LastLig As Long
    Dim idxDate As Variant
    Dim i As Byte
      LastLig = wb2.Sheets("LAG_Bestand").Range("C65536").End(xlUp).Row
    Set plage = wb2.Sheets("LAG_Bestand").Range("C1:AG" & LastLig)
    'LastLig = wb2.Sheets("LAG_Bestand").Range("A65536").End(xlUp).Row
    'Set plage = wb2.Sheets("LAG_Bestand").Range("A7:A" & LastLig)
   idxDate = EquivDate(wb1.Sheets("Warengruppen").Range("B1").Value, plage)
    If idxDate > 0 Then Set c = plage.Cells(idxDate)
    If Not c Is Nothing Then
        For i = 1 To 13
            c.Offset(0, i).Value = wb1.Sheets("Warengruppen").Range("C" & i + 13).Value
        Next i
    End If
    Set c = Nothing
    Set plage = Nothing

Function EquivDate(dte As Date, plage As Range) As Long
   Dim idx
   idx = Application.Match(CLng(dte), plage, 0)
   If Not IsError(idx) Then EquivDate = idx
End Function

Merci pour votre aide et vos explication

 

[pierrejean]

Re : transfert ne se fait pas

bonjour PHILIP

tes macros revisitées

Sub actua()
    Dim wb1 As Workbook, wb2 As Workbook
    Set wb1 = Workbooks("classeur7.xls")
    Set wb2 = Workbooks("classeur6.xls")
    Dim plage As Range, c As Range
    Dim LastLig As Long
    Dim idxDate As Variant
    Dim i As Byte
    LastLig = wb2.Sheets("LAG_Bestand").Range("C65536").End(xlUp).Row
    Set plage = wb2.Sheets("LAG_Bestand").Range("C1:AG" & LastLig)
   idxDate = EquivDate(wb1.Sheets("Warengruppen").Range("B1").Value, plage)
    If idxDate <> "" Then Set c = wb2.Sheets("LAG_Bestand").Range(idxDate)
    If Not c Is Nothing Then
        For i = 1 To 13
            c.Offset(i, 0).Value = wb1.Sheets("Warengruppen").Range("C" & i + 2).Value
        Next i
    End If
    Set c = Nothing
    Set plage = Nothing
End Sub
Function EquivDate(dte As Date, plage As Range) As String
   Set d = plage.Find(dte, LookIn:=xlValues, lookat:=xlWhole)
   If Not d Is Nothing Then
    EquivDate = d.Address
   Else
    EquivDate = ""
   End If
End Function

 

[Lii]

Re : transfert ne se fait pas

Bonsoir,

j'avais ceci :

Sub actua()
    Dim wb1 As Workbook, wb2 As Workbook
    Set wb1 = Workbooks("classeur7.xls")
    Set wb2 = Workbooks("classeur6.xls")
    Dim plage As Range, c As Range
    
    Dim idxDate As Variant
    Dim i As Byte
   
    Set plage = wb2.Sheets("LAG_Bestand").Range("C1:AG[COLOR=Red][B]1[/B][/COLOR]") [B][COLOR=SeaGreen]'*[/COLOR]
[/B]     
   idxDate = EquivDate(wb1.Sheets("Warengruppen").Range("B1").Value, plage)
    If idxDate > 0 Then Set c = plage.Cells(idxDate)
    If Not c Is Nothing Then
        For i = 1 To 1[COLOR=Blue][B]4[/B][/COLOR]
            c.Offset(i, 0).Value = wb1.Sheets("Warengruppen").Range("C" & i +[B] [COLOR=Red]2[/COLOR][/B]).Value
        Next i
    End If
    Set c = Nothing
    Set plage = Nothing
end sub

* on peut trouver le numéro de la dernière cellule non vide de la ligne.

Ajout : la fonction n'est pas modifiée !
Correction en bleu

 

[Paritec]

Re : transfert ne se fait pas

Bonsoir Lii Pierrejean philip
moi j'avais fait cela mais je le mets surtout pour que vous me disiez si c'était pas des grosses bêtises
a+
Papou
Sub actua()
Dim wb1 As Workbook, wb2 As Workbook
Set wb1 = Workbooks("classeur7.xls")
Set wb2 = Workbooks("classeur6.xls")
Dim plage As Range, c As Range
Dim LastLig As Long
Dim idxDate As Variant
Dim i As Byte
LastLig = wb2.Sheets("LAG_Bestand").Range("C65536").End(xlUp).Row
Set plage = wb2.Sheets("LAG_Bestand").Range("C1:AG1")
idxDate = EquivDate(wb1.Sheets("Warengruppen").Range("B1").Value, plage)
If idxDate > 0 Then Set c = plage.Cells(idxDate): x = idxDate + 2
If Not c Is Nothing Then
For i = 2 To 14
Cells(i, x).Value = wb1.Sheets("Warengruppen").Range("C" & i + 1).Value
Next i
End If
Set c = Nothing
Set plage = Nothing
End Sub

 

[PHILIP]

Re : transfert ne se fait pas

Bonsoir ,

Je n'ai pas pu tester les soluces de Jean Pierre, Lii et Paritec que je remercie chaudement , je les testerai demain matin
encore merci à vous