youyou64000
Messages postés6Date d'inscriptionmardi 29 avril 2014StatutMembreDernière intervention21 octobre 2014
-
21 oct. 2014 à 11:57
Mytå
Messages postés2973Date d'inscriptionmardi 20 janvier 2009StatutContributeurDernière intervention20 décembre 2016
-
22 oct. 2014 à 23:20
Bonjour, je suis vraiment bloqué au travail, j'ai un beug avec une macro, j'ai un bouton qui met à jour
Voici la igne qui beuge: "nblignes = Columns(colkey + ":" + colkey).Find("*", Range(colkey + "1"), , , xlByRows, xlPrevious).Row"
Et la macro entiere qui permet d'extraire le text.
Ps: Sur le 2003 cette macro "update" fonctionne tres bien uniquement sur le 2013"
Macro entiere: "Sub propage(colkey As String, form As String, Optional ligdep As Variant)
'
' macro de propagation de formules
' exemple call propage("A","E:H"), ligdep optionnal
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ExportToTextFile
' This exports a sheet or range to a text file, using a
' user-defined separator character.
' be aware that in this version quarter information are replaced by
' the right quarter
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ExportToTextFile(FName As String, _
Sep As String, SelectionOnly As Boolean, _
AppendData As Boolean, blank As String, finlig_Criteria)
Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
'Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile
If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If
If AppendData = True Then
Open FName For Append Access Write As #FNum
Else
Open FName For Output Access Write As #FNum
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
newlig = False
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = blank 'Chr(34) & Chr(34)
If ColNdx <> StartCol Then newlig = True
'correctif apporté à newlig
For offs = 1 To 5
If Cells(RowNdx, ColNdx + Offset) <> "" And (finlig_Criteria = "5 blank cells" Or finlig_Criteria = "") Then newlig = False
Next
ElseIf Not (newlig) Then
CellValue = Replace(Cells(RowNdx, ColNdx).Value, "200nQxx", Quarter_global)
If Region_Global <> "ALL" Then
CellValue = Replace(CellValue, "RegionXXX", Region_Global)
Else
CellValue = Replace(CellValue, "='RegionXXX'", "<>'Unas'")
End If
End If
If (Not (newlig)) Then WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #FNum, WholeLine
Next RowNdx
EndMacro:
On Error GoTo 0
'Application.ScreenUpdating = True
Close #FNum
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' END ExportTextFile
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub AccessData(sh As Variant, area As Variant, queryname As Variant, Optional refreshstyle As Variant)
'area = area concerned by query (without formula)
Application.DisplayAlerts = False
On Error GoTo errorlevel
If IsMissing(refreshstyle) Then
refreshstyle = xlOverwriteCells
End If
Sheets(sh).Select
Cells.Select
Selection.ClearContents
With ActiveSheet.QueryTables.Add(Connection:= _
"FINDER;" & queryname, _
Destination:=Range("A1"))
.Name = "interm1"
.FieldNames = True
.RowNumbers = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.refreshstyle = refreshstyle 'xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.Refresh BackgroundQuery:=False
.FillAdjacentFormulas = True
End With
aaa = 1
Exit Sub
errorlevel:
MsgBox ("Attention pb query" & sh)
'MsgBox ("Attention verifier le mot passe ODBC => voir lien feuille Pilote")
End Sub
Dim tabl(6000, 2) As String
Dim xval As String
On Error Resume Next
nbrows = Range("A1").CurrentRegion.Rows.Count
numm = 0
For i = 2 To nbrows
If Range("A" & CStr(i)).Value <> "" Then
numm = numm + 1
tabl(numm, 2) = Range("C" & CStr(i)).Value
tabl(numm, 1) = Range("A" & CStr(i)).Value
End If
Next
nummax = numm
Sheets("SWG Saas Roadmap").Select
nblig_roadmap = Range("U3").End(xlDown).Row
For i = 3 To nblig_roadmap
xval = Range("O" & CStr(i)) 'xval commentaire initial, si 2 comp separées par /**/
If Trim(Range("N" & CStr(i)).Value) <> "" Then
For l = 1 To nummax
If Range("N" & CStr(i)).Value = tabl(l, 1) Then
If InStr(1, tabl(l, 2), xval) = 0 Then 'xval pas présent dans le commentaire
If InStr(1, xval, "/**/") > 0 Then
Range("O" & CStr(i)) = Mid(xval, 1, InStr(1, xval, "/**/") - 1) & Chr(13) & Chr(10) & "/**/" & Chr(13) & Chr(10) & tabl(l, 2)
Else
Range("O" & CStr(i)) = xval & Chr(13) & Chr(10) & "/**/" & Chr(13) & Chr(10) & tabl(l, 2)
End If
Else
Range("O" & CStr(i)) = tabl(l, 2)
End If
'sheets("Roadmap").select
End Sub
Sub cleaning()
For i = 6 To 2000
If Range("O" & CStr(i)) <> "" And InStr(1, Range("O" & CStr(i)), "*") > 0 Then _
Range("O" & CStr(i)) = Mid(Range("O" & CStr(i)), 1, InStr(1, Range("O" & CStr(i)), "*") - 1)
Next
End Sub
Sub essai()
Dim tabl(2000) As String
On Error Resume Next
Sheets("tempo1").Select
For i = 2 To 1000
tabl(i) = Range("C" & CStr(i)).Value
Next
For i = 2 To 1000
Range("K" & CStr(i)).Value = tabl(i)
Range("L" & CStr(i)).Value = Len(tabl(i))
Next
End
Range("AP6").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=IF(NOT(ISNA(VLOOKUP(RC[-36],Tempo1!C[-41]:C[-39],3,FALSE))),VLOOKUP(RC[-36],Tempo1!C[-41]:C[-39],3,FALSE),"""")"
22 oct. 2014 à 23:20
Essaye de joindre un fichier sans données confidentielles
Pour joindre un fichier utilise https://www.cjoint.com/
et recopie le lien fourni dans ton prochain message.
Mytå