feinte pour un adressage de macro

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
A

alexistak

XLDnaute Occasionnel
Bonjour,
Je cherche une feinte pour une macro.
Le probleme est simple, j ai une macro qui fait des tri en fonction d'un nom specifier dans une case. La macro cherche ensuite dans une colonne toutes les lignes ayant le mem nom que dans la case.
par exemple je veux que les arthur je tappe arthur dans la case D9 et il me sort toutes les lignes avec arthur.
Il faudrait que je trouve une feinte pour que la macro me sorte toute les lignes que dois je mettre a la place de D9
Code: 
' search_for = Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets("Start").Range("D9").Value2
Pour que ca fonctionne avec tous les noms de ma liste
(Elle ne fait pas que trie elle me reformate le doc)
 
Trier par date Trier par votes
Re : feinte pour un adressage de macro

bonjour alexistak

Et on peut avoir une idée de l'endroit ou perche ta liste ????

par la même occasion une petite verification pour savoir comment se comporte la macro ne serait pas forcement inutile

por cela il serait bon qu'on puisse la voir !!
 
Vote positif 0 Vote négatif
Re : feinte pour un adressage de macro

Code: 
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'~~~~~~~~~~~~~Macro to process GCC Violation Report~~~~~~~~~~~~~~
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'***********Violations without Justification for specified Head of Credit**********
Sub Main1()

'***Variables***
Dim GCCReport As Workbook                               'Workbook of report from GCC
Dim row_count As Integer                                'no of rows written

'Delete data written in last import
Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets("Start").Range("D32").ClearContents
Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets("Sheet2").Range("B4:Q23000").Delete

'opens dialog box to choose report
Filename = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Please select a file")
    If Filename = False Then
        ' They pressed Cancel
        MsgBox "Stopping because you did not select a file"
        Exit Sub
    Else
        Workbooks.Open (Filename)
        Set GCCReport = ActiveWorkbook
        
        w_rows = DataExtract
        
 

        GCCReport.Close
        
        End If


MsgBox "Data Import has finished"

Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets(2).Activate
row_count = RowCount

    
    With Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets(2)
        'Set Column Width
        .Columns("A").ColumnWidth = 0
        .Columns("B").ColumnWidth = 10
        .Columns("C").ColumnWidth = 10
        .Columns("D").ColumnWidth = 15
        .Columns("E").ColumnWidth = 15
        .Columns("F").ColumnWidth = 15
        .Columns("G").ColumnWidth = 25
        .Columns("H").ColumnWidth = 15
        .Columns("I").ColumnWidth = 2
        .Columns("J:L").ColumnWidth = 4
        .Columns("J:L").HorizontalAlignment = xlCenter
        .Columns("M").ColumnWidth = 4
        .Columns("N").ColumnWidth = 25
        .Columns("O").ColumnWidth = 20
        .Columns("P").ColumnWidth = 7
        
        
        
        'Set Row Height
        .Rows("4:10000").AutoFit
        
        'Set Borders
        .Range(Worksheets("Sheet2").Cells(4, 1), Worksheets("Sheet2").Cells(row_count, 17)).Borders.Weight = xlHairline
        .Range(Worksheets("Sheet2").Cells(4, 1), Worksheets("Sheet2").Cells(row_count, 17)).Borders.Color = RGB(0, 0, 0)
        .Range(Worksheets("Sheet2").Cells(4, 1), Worksheets("Sheet2").Cells(row_count, 17)).Borders.LineStyle = xlContinuous
'        .Range(Worksheets("Sheet2").Cells(4, 1), Worksheets("Sheet2").Cells(row_count, 17)).Font.FontStyle = "Tahoma"
'        .Range(Worksheets("Sheet2").Cells(4, 1), Worksheets("Sheet2").Cells(row_count, 17)).Font.Size = 10
        .Range("A3:Q3").Borders.LineStyle = xlContinuous
        .Range("A3:Q3").Borders.Weight = xlHairline
        .Range("A3:Q3").Borders.Color = RGB(0, 0, 0)
        
        End With
        
Call ColorUPC(4, row_count, 17, 5)
Call SeperateUPC(4, row_count, 17, 5, False)
Call DeleteJust(False, row_count)
Call PrintSetup(65, 2)

End Sub
'***********Violations with Justification for specified Head of Credit**********
Sub Main2()

'***Variables***
Dim GCCReport As Workbook                               'Workbook of report from GCC
Dim row_count As Integer                                'no of rows written

'Delete data written in last import
Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets(1).Range("D32").ClearContents
Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets("Sheet2").Range("B4:Q23000").Delete

'opens dialog box to choose report
Filename = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Please select a file")
    If Filename = False Then
        ' They pressed Cancel
        MsgBox "Stopping because you did not select a file"
        Exit Sub
    Else
        Workbooks.Open (Filename)
        Set GCCReport = ActiveWorkbook
        
        w_rows = DataExtract
        
 

        GCCReport.Close
        
        End If


MsgBox "Data Import has finished"

Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets(2).Activate
row_count = RowCount

    
    With Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets(2)
        'Set Column Width
        .Columns("A").ColumnWidth = 0
        .Columns("B").ColumnWidth = 10
        .Columns("C").ColumnWidth = 10
        .Columns("D").ColumnWidth = 15
        .Columns("E").ColumnWidth = 15
        .Columns("F").ColumnWidth = 15
        .Columns("G").ColumnWidth = 25
        .Columns("H").ColumnWidth = 15
        .Columns("I").ColumnWidth = 2
        .Columns("J:L").ColumnWidth = 4
        .Columns("J:L").HorizontalAlignment = xlCenter
        .Columns("M").ColumnWidth = 4
        .Columns("N").ColumnWidth = 25
        .Columns("O").ColumnWidth = 20
        .Columns("P").ColumnWidth = 7
        
        
        
        'Set Row Height
        .Rows("4:10000").AutoFit
        
        'Set Borders
        .Range(Worksheets("Sheet2").Cells(4, 1), Worksheets("Sheet2").Cells(row_count, 17)).Borders.Weight = xlHairline
        .Range(Worksheets("Sheet2").Cells(4, 1), Worksheets("Sheet2").Cells(row_count, 17)).Borders.Color = RGB(0, 0, 0)
        .Range(Worksheets("Sheet2").Cells(4, 1), Worksheets("Sheet2").Cells(row_count, 17)).Borders.LineStyle = xlContinuous
'        .Range(Worksheets("Sheet2").Cells(4, 1), Worksheets("Sheet2").Cells(row_count, 17)).Font.FontStyle = "Tahoma"
'        .Range(Worksheets("Sheet2").Cells(4, 1), Worksheets("Sheet2").Cells(row_count, 17)).Font.Size = 10
        .Range("A3:Q3").Borders.LineStyle = xlContinuous
        .Range("A3:Q3").Borders.Weight = xlHairline
        .Range("A3:Q3").Borders.Color = RGB(0, 0, 0)
        
        End With
        
Call ColorUPC(4, row_count, 17, 5)
Call SeperateUPC(4, row_count, 17, 5, False)
Call DeleteJust(True, row_count)
Call PrintSetup(65, 2)

End Sub
    
'~~~~~Function to scan (active) Worksheet~~~~~
'returns row no in which entry was found if succesful, 0 else
'~~~~~Arguments~~~~~
'SearchValue            the value you are looking for
'row_start              row in which scan starts
'wb_to_scan             Workbook which is scanned
'row_max                maximal no of rows to be scanned


Private Function Scan(SearchValue, row_start As Integer, Optional wb_to_scan As Workbook, Optional row_max As Integer = 500) As Integer

            'Column variable
            Dim j As Integer
            
            'sets column to search
            '4 means Head for the credit
            j = 4
           
            
                'Loop Counter
                Dim i As Integer
                i = row_start
                
                'Loop which scans the rows
                Do
                Dim Search1 As String
                Search1 = SearchValue
                Test1 = Worksheets("Sheet1").Cells(i, j).Value2
                'MsgBox Test1 & "   " & VarType(Test1) & "   " & VarType(SearchValue)
                
                If Test1 = Search1 Then
                
            
                Scan = i
                Exit Do
                End If
                
                If row_max < i Then
                Scan = 0
                Exit Do
                End If
                
                i = i + 1
                Loop
                


End Function

D9 c'est l'adress ou il va cherhcer le nom.

Merci
 
Vote positif 0 Vote négatif
Re : feinte pour un adressage de macro

suite du code

Code: 
'~~~~~Function to Extract data~~~~~
'returns nothing
'Uses scan and write function defined above to write data to Risky Names which matches reference Data from GCC Report
'~~~~~Arguments~~~~~
'None

Private Function DataExtract(Optional write_sheet As Integer = 2, Optional wb_to_search As Workbook) As Integer


Dim start_scan As Integer           'start_scan specifies in which row to start search
Dim row_found As Integer            'no of row in which data was found
Dim n As Integer                    'Set column of reference data
n = 1                               'default is 1, means BB ID
Dim m As Integer                    'Loop Counter
m = 2                               'row from which reference data comparison is started
Dim writecount As Integer           'Counts no of row written to "Risky Names"
writecount = 4                      'row to start writing
Dim colorcode As Boolean            'variable which helps define background color to differentiate UPCs



    '*****Set reference value which is looked up in GCC Report I*****
    'This Loop searches for rows with choosen Head of Credit Name
    search_for = Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets("Start").Range("D9").Value2
    
    start_scan = 4
                
    'Actual data search is done in this loop
    Do
                
            'Scan Worksheet for data to retrieve
            row_found = Scan(search_for, start_scan, wb_to_search)
            
            'Gebe Zeile an in welcher Daten gefunden wurden
            If row_found <> 0 Then
            
                'MsgBox "Entry is in row  " & row_found
                Call Write_Data(row_found, writecount, write_sheet)
            
                Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets("Start").Range("D32").Value = "Succesful"
            
                start_scan = row_found + 1
                writecount = writecount + 1
            
            Else
                If start_scan = 6 Then
                Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets("Start").Range("D32").Value = "Not Succesful"
                'MsgBox "Value not found in file"
                End If
            End If
            
            
                
    Loop While (row_found <> 0)
    
    '*****Set reference value which is looked up in GCC Report II*****
    'This loop extracts rows which have no data for col Head of Credit but data for col Issuer
    start_scan = 4
    'Actual data search is done in this loop
    Do
            If Worksheets("Sheet1").Cells(start_scan, 3).Value = " " And Worksheets("Sheet1").Cells(start_scan, 6).Value <> 0 And Worksheets("Sheet1").Cells(start_scan, 7).Value <> "SENSEC_OTH" Then
            
                Call Write_Data(start_scan, writecount)
                writecount = writecount + 1
            
            End If
            
    start_scan = start_scan + 1
    Loop While (start_scan < 500)

DataExtract = writecount
End Function

'~~~~~Function to Write data~~~~~
'writes entire row of specified cell to file "Risky Names"returns String
'Uses scan and write function defined above to write data to Risky Names which matches reference Data from GCC Report
'~~~~~Arguments~~~~~
'copy_row                     specifies row to copy
'write_row                    specifies row into which is written


Private Sub Write_Data(copy_row As Integer, write_row As Integer, Optional sheet As Integer = 2, Optional set_color As Boolean)

'Copy from GCC Report and write data to Risky Names
Worksheets("Sheet1").Cells(copy_row, 1).EntireRow.Copy (Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets(sheet).Cells(write_row, 1))


'With Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets(2).Range(Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets(2).Cells(write_row, 1), Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets(2).Cells(write_row, 17))
'    .Borders.LineStyle = xlContinuous
'    .Borders.Weight = xlHairline
'    .Borders.Color = RGB(0, 0, 0)
'    .Font.FontStyle = "Tahoma"
'    .Font.Size = 10
'End With

'Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets(2).Cells(write_row, 8).Font.Bold = True
        
If set_color = False Then
    'Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets("Sheet1").Range(Cells(write_row, 1), Cells(write_row, 36)).Interior.color = RGB(92, 172, 238)
End If


End Sub

'~~~~~~~~~~~~~~~~~Function to count rows in GCCReports~~~~~~~~~~~~~~~~~
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function RowCount() As Integer

Dim m As Integer            'Loop Counter
m = 7

Do While (Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets(2).Cells(m, 6).Value <> 0)

m = m + 1
Loop

RowCount = m - 1

End Function

'~~~~~~~~~~~~~~~~~~~Sub to color UPCs in order to separate them~~~~~~~~~~~~~~~~~~~
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Arguments~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'start_row              specifies where to start the separation of UPCs
'row_max                row in which to end sub
'col_max                column until which background color should be changed
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'uses UPC as reference to sort


Sub ColorUPC(start_row As Integer, row_max As Integer, col_max As Integer, Optional comp_row As Integer = 3)

Dim i As Integer
i = start_row
marker = 0
'MsgBox row_max

Do While (i <= row_max)

If Worksheets("Sheet2").Cells(i, comp_row + 1) <> Worksheets("Sheet2").Cells(i - 1, comp_row + 1) Then
    
    With Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(i, 1), Worksheets("Sheet2").Cells(i, col_max + 1)).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .Color = RGB(0, 0, 0)
    End With
    
    marker = marker + 1
    'MsgBox "Marker  " & marker & " Loop counter  " & i
End If

If (marker Mod 2 = 0) Then
    Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(i, 2), Worksheets("Sheet2").Cells(i, col_max + 1)).Interior.Color = RGB(255, 228, 181)
End If


i = i + 1
Loop

End Sub

Sub SeperateUPC(start_row As Integer, row_max As Integer, col_max As Integer, Optional comp_row As Integer = 2, Optional del As Boolean = True)

Dim i As Integer
i = start_row
before = Worksheets("Sheet2").Cells(i - 1, comp_row + 1)

Do While (i <= row_max)
    
    If Worksheets("Sheet2").Cells(i, comp_row + 1) = before Then
    
    before = Worksheets("Sheet2").Cells(i, comp_row + 1)
    
    If del = True Then
    Worksheets("Sheet2").Cells(i, comp_row - 1).ClearContents
    End If
    
    Worksheets("Sheet2").Cells(i, comp_row + 1).ClearContents
    
    
    
    Else
    
    before = Worksheets("Sheet2").Cells(i, comp_row + 1)
    
    End If
    
    i = i + 1
    
Loop

End Sub

Sub PrintSetup(resize As Double, sheet As Integer)

Dim Run As Boolean

Run = Application.Dialogs(xlDialogPrinterSetup).Show
    
If Run = False Then
MsgBox "Stopping Print Setup since no printer was chosen"
Exit Sub
Else
    '************Page Setup***************
    With Workbooks("GCC Violation Report Filter MacroV2.1.xls").Worksheets(sheet).PageSetup
        '.PaperSize = xlPaperA3
        .Zoom = resize
        .Orientation = xlLandscape
        .TopMargin = 0.5
        .BottomMargin = 0.5
        .RightMargin = 0.5
        .LeftMargin = 0.5
        '.PrintArea = "A1:AR10"
    End With
   
Application.Dialogs(xlDialogPrintPreview).Show
End If
'    '************Print Dialog***********
'    ActiveWorkbook.Worksheets(1).PrintOut
        
End Sub

'**********Sub to delete either rows with justification or without justification
Sub DeleteJust(exists As Boolean, row_max As Integer)
Dim i As Integer
i = 4
Dim row_max_i As Integer
row_max_i = row_max

If exists = True Then
Do
    If Worksheets("Sheet2").Cells(i, 14).Value = " " Then
        Worksheets("Sheet2").Rows(i).Delete
        i = i - 1
        row_max_i = row_max_i - 1
    End If
i = i + 1
Loop While (i < row_max_i)

If Worksheets("Sheet2").Cells(row_max_i, 14).Value = " " Then
Worksheets("Sheet2").Rows(row_max_i).Delete
End If

Else
Do
    If Worksheets("Sheet2").Cells(i, 14).Value <> " " Then
        Worksheets("Sheet2").Rows(i).Delete
        i = i - 1
        row_max_i = row_max_i - 1
    End If
i = i + 1
Loop While (i < row_max_i)

If Worksheets("Sheet2").Cells(row_max_i, 14).Value <> " " Then
Worksheets("Sheet2").Rows(row_max_i).Delete
End If

End If

End Sub
 
Vote positif 0 Vote négatif
Re : feinte pour un adressage de macro

Re

Voila ce que j'ais pu tirer de ce que tu nous a fourni

1) la cellule D9 est utilisée par la fonction DataExtract
2 la fonction DataExtract est utilisée dans les sub Main1 et Main2 pour definir la variable w_rows
3) cette variable n'est apparement utilisée nulle part dans ce qui est fourni !!

Il est pour le moins penible de chercher dans ces conditions !!!

Peux-tu nous en dire un peu plus ???

Quelle action tu effectues lorsque D9 esr renseigné ?

Sinon tu peux toujours faire quelque chose du genre

Code: 
for each cel in liste
range("D9)=cel.value
....
next cel
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

M
  • Question Question
XL 2016 pb création de tableau par macro
Réponses
10
Affichages
272
ChTi160
ChTi160
Jiheme
  • Question Question
XL 2019 Macro bloque en court de travail
Réponses
4
Affichages
256
fanch55
fanch55
Y
  • Question Question
XL 2019 macro pour dupliquer un tableau
Réponses
3
Affichages
462
Yogean
Y
A
  • Question Question
Microsoft 365 Macro pour recherche de cellules entre 2 fichiers Excel
Réponses
7
Affichages
348
AtTheOne
AtTheOne
W
  • Question Question
XL 2019 Transformer des lignes de codes pour pratiquer Tablo à 4 colonnes et 40 lignes
2 3
Réponses
40
Affichages
1 K
Webperegrino
W
Z
  • Question Question
XL 2016 Macro pour copier plusieurs cellules vers un fichier :(
Réponses
3
Affichages
471
zendb
Z
K
  • Question Question
XL 2016 Coup de main pour créer un fichier Excel qui gère le suivi des visites médicales du personnel.
Réponses
4
Affichages
360
dysorthographie
dysorthographie
P
  • Question Question
XL 2019 Macro VBA appliquer un filtre lors d'une importation de données
Réponses
1
Affichages
395
fanch55
fanch55
O
  • Question Question
Autres recopie de cellules selon la date
Réponses
3
Affichages
287
olivier Clech
O
S
  • Question Question
Macro associée à un bouton
Réponses
12
Affichages
421
Santino007
S
G
  • Question Question
XL 2021 Macro pour changer les titres de fichier d'archive
Réponses
3
Affichages
599
fanch55
fanch55
N
  • Question Question
XL 2016 Récupération de lignes dans un autre fichier excel
Réponses
4
Affichages
447
ninieg
N
T
  • Question Question
Microsoft 365 Macro pour rendre visible les lignes de couleur masquées par des filtres
Réponses
3
Affichages
346
Phil69970
Phil69970
C
  • Résolu(e)
Copier/Masquer des lignes de couleur pour alimenter un tableau
Réponses
9
Affichages
795
vgendron
vgendron
N
  • Résolu(e)
Microsoft 365 Transfère de données d'un Userform vers un tableau structuré d'une feuille de calcul
Réponses
4
Affichages
401
NONO14
N
jeff1494
  • Question Question
XL 2021 Comment supprimer des noms du gestionnaire de noms dans un classeur
Réponses
7
Affichages
757
jeff1494
jeff1494
S
  • Question Question
XL 2019 Calculer dimanche de pâques puis insertion du 29 février
2
Réponses
26
Affichages
877
dysorthographie
dysorthographie
B
  • Résolu(e)
XL 2021 Séparer les adresses (Rue et N°) en 2 cellules avec un macro
2
Réponses
20
Affichages
2 K
Banbara
B
P
  • Résolu(e)
XL 2021 Besoin d'aide pour copier/coller données de plusieurs classeurs
2
Réponses
20
Affichages
1 K
Pac41240
P
J
  • Question Question
Microsoft 365 macro qui ouvre des fichiers excel de type "analyze in excel" généré par power bi et met à jour un filtre "mois" sur plusieurs tcd
Réponses
0
Affichages
562
JJ69
J
Retour