XL 2016 Remplacer cellule par une autre si cellule vide sur 2 colonnes

[stephanie94]

Bonjour, voila mes connaissances en macro sont limités et j'ai cherche avec des formules mais je ne trouve pas de solution:
je vous joins le ficchier avec le point de depart et ce que j'aimerais car je ne sais pas trop expliquer a part qu'il faudrait remplacer une cellule par une autre une cellule sur 2 sur 2 colonnes differentes. il faudrait si possible ensuite transposer les donnees de la seconde colonne en 2 colonnes
Je joins le fichier avec la base et ce que je voudrais (en commentaire les cellules a reprendre
cela me sauverait la journée car j'ai 150 onglets avec environ 500 lignes à traiter
merci d'avance
cordialement

 

[Excel_addin]

Bonjour stéphanie94, le forum

je propose un début de solution, n'ayant que peu de temps devant moi.

Sub data_back()

  With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    On Error GoTo catch_Erreurs

Dim cRange As Range

For Each ong In ActiveWorkbook.Sheets ' boucle sur tous les onglets
     If ong.Range("a1") = "col1" Then

        For Each cRange In ong.Range("A1:A5") 'Range(Range("A1"), Range("A65000").End(xlUp))
       
            If cRange.Hyperlinks.Count = 1 Then
            phr = cRange.Offset(1, 1)
           
            cRange.Copy ong.Range("G65000").End(xlUp).Offset(1)
            ong.Range("H65000").End(xlUp).Offset(1) = phr
            ong.Range("I65000").End(xlUp).Offset(1) = Mid(phr, 1, InStr(phr, "."))
            ong.Range("J65000").End(xlUp).Offset(1) = Replace(Mid(phr, 1, InStr(phr, ";") - 1), Mid(phr, 1, InStr(phr, ".")), "")
       
            End If
           
        Next cRange
       
     End If
   
Next ong

catch_Erreurs:
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

 

[stephanie94]

merci pour ton aide, mais la macro ne fonctionne pas
cordialement

 

[Excel_addin]

merci pour ton aide, mais la macro ne fonctionne pas
cordialement

Peux-tu m'en dire plus ?
Quelle est l'erreur affichée ? ou autre.
Cordialement

 

[Excel_addin]

Une nouvelle version ...
Cordialement

Sub data_back()

  With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    On Error GoTo catch_Erreurs

Dim cRange As Range
Dim cRow As Double

For Each ong In ActiveWorkbook.Sheets ' boucle sur tous les onglets
     If ong.Range("a1") = "col1" Then

        For Each cRange In ong.Range("A1:A5") 'Range(Range("A1"), Range("A65000").End(xlUp))
      
            If cRange.Hyperlinks.Count = 1 Then
            phr = cRange.Offset(1, 1)
          
            cRow = ong.Range("G1").End(xlDown).Offset(1).Row
          
            cRange.Copy ong.Range("G" & cRow)
            ong.Range("H" & cRow) = phr
            ong.Range("I" & cRow) = Mid(phr, 1, InStr(phr, "."))
            ong.Range("J" & cRow) = Replace(Mid(phr, 1, InStr(phr, ";") - 1), Mid(phr, 1, InStr(phr, ".")), "")
      
            End If
          
        Next cRange
      
     End If
  
Next ong

catch_Erreurs:
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

 

[sylvanu]

Bonjour Stéphanie, Excel-addin,
Un essai en PJ. Avec :

Sub Traitement()
' Suppression ligne contenant Page
    Application.ScreenUpdating = False
    DL = Range("A65500").End(xlUp).Row
    For L = DL To 2 Step -1
        If Left(Cells(L, "A"), 4) = "Page" Then Cells(L, 1).EntireRow.Delete
        Application.StatusBar = "Phase 0. N° ligne traitée : " & L
    Next L
' Déplacement cellule A en B
    DL = Range("A65500").End(xlUp).Row
    For L = DL To 3 Step -2
        Cells(L - 1, "B") = Cells(L, "A")
        Cells(L, 1).EntireRow.Delete
        Application.StatusBar = "Phase 1. N° ligne traitée : " & L
    Next L
' Extraction Titre
    DL = Range("A65500").End(xlUp).Row
    For L = DL To 2 Step -1
        Cells(L, "C") = Mid(Cells(L, "B"), InStr(1, Cells(L, "B"), ".") + 1)
        Application.StatusBar = "Phase 2. N° ligne traitée : " & L
        PlacePoint = InStr(1, Cells(L, "C"), ".")
        Cells(L, "C").Characters(Start:=1, Length:=PlacePoint).Font.Bold = True
    Next L
' Journal et année
    DL = Range("A65500").End(xlUp).Row
    For L = DL To 2 Step -1
        tablo = Split(Cells(L, "C"), ".")
        Cells(L, "D") = tablo(0)
        Cells(L, "E") = Val(Left(Trim(tablo(1)), 4))
        Application.StatusBar = "Phase 3. N° ligne traitée : " & L
    Next L
' Suppression colonne B
    Columns("B:B").Delete Shift:=xlToLeft   ' A remettre si texte original doit être conservé
' Mise en forme
    Columns("A:C").ColumnWidth = 47
    Columns("D:D").ColumnWidth = 6
    Columns("A:C").WrapText = True
    Cells.EntireRow.AutoFit
    ActiveWindow.ScrollColumn = 1: ActiveWindow.ScrollRow = 1
    Set F = ActiveSheet.UsedRange
    [A1].Activate
    Application.StatusBar = ""
End Sub

J'ai bien gardé séparé les différentes taches car la BDD n'est "pas propre", comme la présence de PAGE1,2 ... qui perturbe le traitement. Celui ci est corrigé mais il y en a peut être certains autres.
Pour lancer la macro faire ALT+F8 et Traitement.
Dans la PJ le résultat obtenu est en feuil2.

 

[stephanie94]

merci merci merci cela me sauve vraiment, j'ai gagné un temps phénoménal