VBA 13 - Problem macro => extraction de texte

Fermé
youyou64000 Messages postés 6 Date d'inscription mardi 29 avril 2014 Statut Membre Dernière intervention 21 octobre 2014 - 21 oct. 2014 à 11:57
Mytå Messages postés 2973 Date d'inscription mardi 20 janvier 2009 Statut Contributeur Dernière intervention 20 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

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:

1 réponse

Mytå Messages postés 2973 Date d'inscription mardi 20 janvier 2009 Statut Contributeur Dernière intervention 20 décembre 2016 948
22 oct. 2014 à 23:19
Salut le Forum

Aucun problème avec la commande, à condition que la colonne ne soit pas vide.
nblignes = Columns(colkey + ":" + colkey).Find("*", Range(colkey + "1"), , , xlByRows, xlPrevious).Row 

Mytå
0
Mytå Messages postés 2973 Date d'inscription mardi 20 janvier 2009 Statut Contributeur Dernière intervention 20 décembre 2016 948
22 oct. 2014 à 23:20
Re le Forum

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å
0