VBA 13 - Problem macro => extraction de texte
youyou64000
Messages postés
6
Date d'inscription
Statut
Membre
Dernière intervention
-
Mytå Messages postés 2973 Date d'inscription Statut Contributeur Dernière intervention -
Mytå Messages postés 2973 Date d'inscription Statut Contributeur Dernière intervention -
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
If IsMissing(ligdep) Then ligdep = 2
nblignes = Columns(colkey + ":" + colkey).Find("*", Range(colkey + "1"), , , xlByRows, xlPrevious).Row
t = Split(form, ":")
firstcol = t(0)
lastcol = t(1)
Range(firstcol + CStr(ligdep) + ":" + lastcol + CStr(ligdep)).Select
Selection.AutoFill Destination:=Range(firstcol + CStr(ligdep) + ":" + lastcol + CStr(nblignes)), Type:=xlFillDefault
Columns(form).Calculate
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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
Sub inclus_comment()
'Dim tabl$(2000)
Application.Calculation = xlCalculationManual
Sheets("Parms").Select
Range("A2:A5").Select
ExportToTextFile FName:="C:\windows\temp\queryS.dqy", Sep:=Chr(9), _
SelectionOnly:=True, AppendData:=False, blank:="", finlig_Criteria:="5 blank cells"
Sheets("tempo1").Select
Call AccessData(sh:="tempo1", area:="A:AA", queryname:="C:\windows\temp\queryS.dqy")
Range("C1").Value = "CommentsUpd"
Range("C2").FormulaR1C1 = "=IF(RC[-1]<>"""",RC[-1],"""")" '"=VLOOKUP(RC[-2],Roadmap!C[3]:C[12],10,FALSE) & RC[-1]"
Call propage("A", "C:C")
Columns("C:C").Calculate
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
End If
Next
End If
Next
Erase tabl
Application.Calculation = xlCalculationAutomatic
'Debug.Print "apres query1 temps=>" & Round((Time - timeini) * 86400)
'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),"""")"
End Sub

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
If IsMissing(ligdep) Then ligdep = 2
nblignes = Columns(colkey + ":" + colkey).Find("*", Range(colkey + "1"), , , xlByRows, xlPrevious).Row
t = Split(form, ":")
firstcol = t(0)
lastcol = t(1)
Range(firstcol + CStr(ligdep) + ":" + lastcol + CStr(ligdep)).Select
Selection.AutoFill Destination:=Range(firstcol + CStr(ligdep) + ":" + lastcol + CStr(nblignes)), Type:=xlFillDefault
Columns(form).Calculate
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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
Sub inclus_comment()
'Dim tabl$(2000)
Application.Calculation = xlCalculationManual
Sheets("Parms").Select
Range("A2:A5").Select
ExportToTextFile FName:="C:\windows\temp\queryS.dqy", Sep:=Chr(9), _
SelectionOnly:=True, AppendData:=False, blank:="", finlig_Criteria:="5 blank cells"
Sheets("tempo1").Select
Call AccessData(sh:="tempo1", area:="A:AA", queryname:="C:\windows\temp\queryS.dqy")
Range("C1").Value = "CommentsUpd"
Range("C2").FormulaR1C1 = "=IF(RC[-1]<>"""",RC[-1],"""")" '"=VLOOKUP(RC[-2],Roadmap!C[3]:C[12],10,FALSE) & RC[-1]"
Call propage("A", "C:C")
Columns("C:C").Calculate
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
End If
Next
End If
Next
Erase tabl
Application.Calculation = xlCalculationAutomatic
'Debug.Print "apres query1 temps=>" & Round((Time - timeini) * 86400)
'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),"""")"
End Sub
A voir également:
- VBA 13 - Problem macro => extraction de texte
- Texte de chanson gratuit pdf - Télécharger - Vie quotidienne
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Fifa 13 - Télécharger - Jeux vidéo
- Transcription audio en texte word gratuit - Guide
- Excel cellule couleur si condition texte - Guide
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å