Buongiorno
@ges
e a tutti
Con riferimento a questa discussione
www.forumexcel.it
ho provato a chiedere (allegando il file) di scrivere una macro che desse il risultato desiderato.
Dopo qualche tentativo andato a vuoto (e mi sembra normale vista la complessità della questione) mi ha dato questo codice che mi pare funzioni correttamente
A parte un banalissimo errore in riga 12 (aveva scritto
Cosa ne pensate?
Personalmente non sono in grado di dire se vi siano ridondanze o "errori" che non impediscono il corretto funzionamento del codice.
@ges
e a tuttiCon riferimento a questa discussione
Domanda - Suddivisione nota testuale in contenuto "sensato"
Buongiorno a tutti, già il titolo è incomprensibile figuriamoci la spiega. :occhispalancati: Molto impropriamente abbiamo utilizzato due campi note testuali per indicare la suddivisione di un articolo padre in sottoformati indicandone la lunghezza in millimetri. Ora la sfida impossibile è...
ho provato a chiedere (allegando il file) di scrivere una macro che desse il risultato desiderato.
Dopo qualche tentativo andato a vuoto (e mi sembra normale vista la complessità della questione) mi ha dato questo codice che mi pare funzioni correttamente
Visual Basic:
Sub CreaTabella()
Dim ws As Worksheet
Dim OutRow As Long
Dim LastRow As Long
Dim R As Long
Dim Cod As String
Dim Des As String
Dim Nota As String
Dim Lotto As String
Set ws = ActiveSheet
ws.Range("E1:H100000").ClearContents
ws.Range("E1") = "CODICE"
ws.Range("F1") = "DESCRIZIONE"
ws.Range("G1") = "LUNGHEZZA"
ws.Range("H1") = "LOTTO"
OutRow = 2
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For R = 2 To LastRow
Cod = ws.Cells(R, 1).Value
Des = ws.Cells(R, 2).Value
Nota = LCase(ws.Cells(R, 3).Value)
Lotto = ""
Call EstraiLotto(Nota, Lotto)
Nota = Replace(Nota, "<->", "+")
Nota = Replace(Nota, "-", "+")
Nota = Replace(Nota, "l=", "")
Nota = Replace(Nota, "mm", "")
Nota = Replace(Nota, " ", " ")
Call AnalizzaNota(Nota, Cod, Des, Lotto, ws, OutRow)
Next
MsgBox "Fine"
End Sub
Private Sub AnalizzaNota(Testo As String, Cod As String, Des As String, Lotto As String, _
ws As Worksheet, ByRef OutRow As Long)
Dim T() As String
Dim X As Variant
Dim S As String
Dim P As Long
Dim Qta As Long
Dim Valore As Long
Dim I As Long
Testo = Replace(Testo, "+", " + ")
T = Split(Testo, " ")
For I = LBound(T) To UBound(T)
S = Trim(T(I))
If S = "" Then GoTo Continua
If InStr(S, "/") > 0 Then GoTo Continua
If Left(S, 2) = "l." Then GoTo Continua
If InStr(S, "pz") > 0 Then
P = InStr(S, "pz")
Qta = Val(Left(S, P - 1))
If Len(Mid(S, P + 2)) > 0 Then
Valore = Val(Mid(S, P + 2))
Else
I = I + 1
Do While I <= UBound(T)
If IsNumeric(T(I)) Then
Valore = CLng(T(I))
Exit Do
End If
I = I + 1
Loop
End If
Dim K As Long
For K = 1 To Qta
ws.Cells(OutRow, 5) = Cod
ws.Cells(OutRow, 6) = Des
ws.Cells(OutRow, 7) = Valore
If Lotto <> "" Then
ws.Cells(OutRow, 8) = Lotto
End If
OutRow = OutRow + 1
Next K
Else
If IsNumeric(S) Then
Valore = CLng(S)
If Valore > 0 Then
ws.Cells(OutRow, 5) = Cod
ws.Cells(OutRow, 6) = Des
ws.Cells(OutRow, 7) = Valore
If Lotto <> "" Then
ws.Cells(OutRow, 8) = Lotto
End If
OutRow = OutRow + 1
End If
End If
End If
Continua:
Next I
End Sub
Private Sub EstraiLotto(ByRef Testo As String, ByRef Lotto As String)
Dim P1 As Long
Dim P2 As Long
P1 = InStr(Testo, "(l.")
If P1 = 0 Then Exit Sub
P2 = InStr(P1, Testo, ")")
If P2 = 0 Then Exit Sub
Lotto = Mid(Testo, P1 + 3, P2 - P1 - 3)
Testo = Left(Testo, P1 - 1) & Mid(Testo, P2 + 1)
End SubA parte un banalissimo errore in riga 12 (aveva scritto
ws.Range("E:H100000").ClearContents e quindi andava in debug altri errori non ce ne sono stati.Cosa ne pensate?
Personalmente non sono in grado di dire se vi siano ridondanze o "errori" che non impediscono il corretto funzionamento del codice.
e scusa se mi sono accodato alla tua precedente discussione.
