Discussion :

[bentor22]

Bonjour a tous,

J aimerai faire une macro qui me selectIonne les cellules d une colonne d un fichier nommé fichier 1, dans la feuille nommé feuille 1 colonne A et qu il me les colle dans un autre fichier nomme fichier 2, dans la feuille nommé feuille 2 dans la colonne B.

Également, j aimerai dans la feuille 1, colonne A qu il me sélectionne UNIQUEMENT les cellule qui ne sont pas en gras.

En vous remerciant d avance.

Cordialement

[Philippe Tulliez]

Bonjour,
Voici déjà une réponse pour la première partie de ta question
Exemple de la copie de la colonne B de la feuille nommée db vers la colonne A de la feuille nommée Feuil1

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Option Explicit
Const column As Integer = 2 ' Numéro de la colonne à copier
Sub Test()
 Dim rngF As Range, rngT
 With ThisWorkbook
 Set rngF = .Worksheets("db").Range("A1").CurrentRegion
 Set rngT = .Worksheets("Feuil1").Range("A1")
 End With
 Set rngF = rngF.Offset(0, column - 1).Resize(, 1)
 rngF.Copy rngT
End Sub

Bonjour,
Réponse partielle à la deuxième partie (partielle parce-que tu obtiens la liste des cellules trouvées qui sont en gras).
Je suppose qu'avec la réponse à la première partie et celle-ci tu peux faire la copie.
Exemple de recherche dans la colonne B de la feuille nommée db des cellules qui sont en gras.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub test2()
 Const column As Integer = 2 ' N° de colonne 
 Dim rngF As Range, myTable()
 Dim Elem As Long, txt As String
 With ThisWorkbook
 Set rngF = .Worksheets("db").Range("A1").CurrentRegion
 End With
 Set rngF = rngF.Offset(0, column - 1).Resize(, 1)
 myTable = SearchBold(rngF)
 If myTable(0) = False Then MsgBox "Pas trouvé ": Exit Sub
 txt = "Liste des adresses trouvées"
 With rngF
  For Elem = 1 To UBound(myTable)
   txt = txt & vbCrLf & .Cells(myTable(Elem), .column).Address
  Next
 End With
 MsgBox txt
End Sub

La fonction de recherche renvoie une table.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Function SearchBold(SearchArea As Range) As Variant
 Dim c As Range, firstAddress As String, count As Long
 Dim myTable()
 With Application.FindFormat
 .Clear
 .Font.Bold = True
 End With
 ReDim Preserve myTable(count): myTable(0) = False
 With SearchArea
  Set c = .Find(what:="", searchformat:=True)
  Select Case True
   Case Not c Is Nothing
    firstAddress = c.Address: count = count + 1
    ReDim Preserve myTable(count): myTable(0) = True: myTable(count) = c.Row
   Case Else: SearchBold = myTable: Exit Function
  End Select
  '
  Do
   Set c = .Find(what:="", after:=c, searchformat:=True)
  If Not c Is Nothing And c.Address <> firstAddress Then
   count = count + 1: ReDim Preserve myTable(count): myTable(count) = c.Row
  End If
  Loop While Not c Is Nothing And c.Address <> firstAddress
 
 End With
 SearchBold = myTable
End Function

[bentor22]

Bonjour Philippe et merci de ta réponse,

Toutefois je pense m être mal exprimé,

Je reformule mon problème:

G une liste dans la colonne C d un fichier nomme : reporting 1 dans la feuille nommé: feuille 1.

De cette colonne, je ne veux sélectionner que les cellules qui ne sont pas en gras ET les copier dans un autre fichier qui se nomme:reporting mis a jour , dans la feuille nommé :feuille 3 dans la colonne A.

Merci d avance pour ton retour et ton aide précieuse.

Bien cordialement.

[Philippe Tulliez]

Bonjour,
Une autre approche

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub Test()
 Const column As Integer = 2
 Dim rngF As Range, myTable()
 Dim Elem As Long, txt As String
 With ThisWorkbook
 Set rngF = .Worksheets("db").Range("A1").CurrentRegion
 End With
 Set rngF = rngF.Offset(0, column - 1).Resize(, 1)
 myTable = SearchFormat(rngF)
 If myTable(0) = False Then MsgBox "Pas trouvé ": Exit Sub
 For Elem = 1 To UBound(myTable)
   txt = txt & vbCrLf & myTable(Elem)
 Next
 MsgBox txt
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Function SearchFormat(SearchArea As Range) As Variant
 Dim c As Range, R As Long, count As Long
 Dim myTable()
 ReDim Preserve myTable(count): myTable(0) = False
 For Each c In SearchArea
  If c.Font.Bold = False Then
   count = count + 1: ReDim Preserve myTable(count): myTable(count) = c.Address
  End If
 Next
 myTable(0) = UBound(myTable) > 1: SearchFormat = myTable
End Function

[bentor22]

Bonjour et merci pour votre réponse.

Toutefois je ne vois pas comment vous différenciez les 2 fichiers car il y a le fichier reporting 1 d ou je copie mes données qui ne sont pas en gras pour les coller dans un autre fichier qui se nomme reporting mis a jour.

Merci d avance

[Philippe Tulliez]

Bonjour,
Voici une autre version de la fonction qui renvoie un range et avec un argument facultatif qui prend l'étiquette de colonne.
La variable Objet rngF est le range à copier, rngT est le range de destination

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Sub test2()
 Const column As Integer = 2
 Dim rngF As Range, rngT As Range, myTable()
 Dim Elem As Long, txt As String
 With ThisWorkbook
  Set rngF = .Worksheets("db").Range("A1").CurrentRegion
  Set rngT = .Worksheets("Feuil1").Range("A1")
 End With
 Set rngF = rngF.Offset(0, column - 1).Resize(, 1)
 Set rngF = SearchFormat(rngF, False)
 If Not rngF Is Nothing Then rngF.Copy rngT
End Sub

La fonction qui renvoie un Range

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Function SearchFormat(SearchArea As Range, Optional withLabel As Boolean = True) As Range
 ' Fonction qui renvoie un objet Range (toutes les cellules en gras)
 'Philippe Tulliez 26/01/2013
 'Arguments
 ' SearchArea : Range
 ' [WithLabel]: Boolean Si l'on souhaite que la fonction renvoie la première cellule [d:True]
 
 Dim c As Range, NewRange As Range, flag As Boolean
 For Each c In SearchArea
  If withLabel And flag = False Then Set NewRange = c: flag = True
  If c.Font.Bold = False Then
   Select Case flag
    Case False: Set NewRange = c: flag = True
    Case Else: Set NewRange = Application.Union(NewRange, c)
   End Select
  End If
 Next c
 Set SearchFormat = NewRange
End Function

[bentor22]

Merci énormément.

Toutefois n est il pas mieux de mettre:

Set rngf=.workbooks(reporting1) .worksheets ect.......