Страницы: 1
RSS
VBA. Извлечение данных между символами
 
Доброго времени суток, Знатоки!
Очень нужна помощь в написании VBA кода.

Имеем Номер ГТД и Страну в разных форматах (колонка GTD Info), нужно информацию в одной колонке разделить на 3

например, имеем [10009190/190819/0003170/006]+[IT]
в колонке GTD No должно быть 10009190/190819/0003170/006
в колонке Country No (ISO) должно быть 380
в колонке Country Name должно быть Италия

во вложенном файле есть пример того, как должны быть заполнены колонки. а также на листе Country List - данные по странам, на основании которых должны заполняться колонки
я бы воспользовалась формулой SEARCH, но у меня возникает проблема, когда в одной строке несколько номеров и все они должны быть указаны
Изменено: Мария - - 05.02.2020 16:42:34
 
Код
Option Explicit
'
Sub Main()
    Dim a As Variant
    a = Range(Cells(1, "D"), Cells(Rows.Count, "D").End(xlUp))
    Dim y As Long
    Dim s As String
    For y = 2 To UBound(a, 1)
        If Not IsEmpty(a(y, 1)) Then
            Job_s a, y
        End If
    Next
End Sub
'
Sub Job_s(a As Variant, y As Long)
    Dim b As Variant
    b = Split(a(y, 1), "+")
    
    Dim s1 As String
    Dim s2 As String
    Dim s3 As String
    s1 = b(0)
    s1 = Replace(s1, "[", "")
    s1 = Replace(s1, "]", ", ")
    s1 = Replace(s1, "/" & Chr(10), ";" & Chr(10))
    If Right(s1, 2) = ", " Then s1 = Left(s1, Len(s1) - 2)
    Cells(y, "J").Value = s1
    
    Dim d As Object:    Set d = CreateObject("Scripting.Dictionary")
    Dim l As Object:    Set l = CreateObject("Scripting.Dictionary")
    Dim i As Long
    Dim s As String
    For i = 1 To UBound(b)
        s = ""
        b(i) = Replace(b(i), Chr(10), "")
        If Left(b(i), 1) = "[" Then
            Job_b b(i), d, l
        Else
            s = Mid(b(i), 1, 2)
        End If
        
        If s <> "" Then
            If WorksheetFunction.CountIfs(Sheets("Country List").Columns("B:B"), s) > 0 Then
                d.Item(d.Count) = WorksheetFunction.VLookup(s, Sheets("Country List").Columns("B:C"), 2, 0)
                l.Item(d.Count) = Sheets("Country List").Cells(WorksheetFunction.Match(s, Sheets("Country List").Columns("B:B"), 0), 1).Value
            End If
        End If
    Next
    If d.Count > 0 Then s2 = Join(d.Items(), ";" & Chr(10))
    If l.Count > 0 Then s3 = Join(l.Items(), ";" & Chr(10))
    Cells(y, "K").Value = s2
    Cells(y, "L").Value = s3
    
    
End Sub
'
Sub Job_b(ByVal s As String, d As Object, l As Object)
    Dim c As Variant
    c = Split(s, "/")
    
    Dim t As String
    Dim i As Long
    For i = 0 To UBound(c)
        t = ""
        If Left(c(i), 1) = "[" Then
            t = Mid(c(i), 2, 2)
        End If
        
        If t <> "" Then
            If WorksheetFunction.CountIfs(Sheets("Country List").Columns("B:B"), t) > 0 Then
                d.Item(d.Count) = WorksheetFunction.VLookup(t, Sheets("Country List").Columns("B:C"), 2, 0)
                l.Item(d.Count) = Sheets("Country List").Cells(WorksheetFunction.Match(t, Sheets("Country List").Columns("B:B"), 0), 1).Value & ", " & Mid(c(i), 5, Len(c(i)))
            End If
        End If
    Next
End Sub
 
Цитата
Мария - написал: Имеем Номер ГТД
Всегда будет сохранена схема "]Q2.000+[" или "]Q4,000/[" между основными частями кода GTD, или здесь могут быть другие буквы чем "Q" и символы "+", "/" ?
 
МатросНаЗебре, код работает не правильно, если строка с несколькими ГТД показывается в одну строку. Разделение номеров происходит через "/", страна вообще показывается только одна, а не 3 как должно быть.
При этом, если двойным щелчком раскрыть строку, чтобы каждый номер был на новой строке в ячейке, все работает нормально.
еще вопрос по строкам, когда одна ГТД и не указано количество. после указания страны стоит ",".
Изменено: Мария - - 06.02.2020 08:13:27
 
ocet p,
"Q" - всегдя обозначение количества.
"+" - всегдя разделитель номера ГТД и страны
"[ ]" - номер ГТД всегда в квадратных скобках
"/" - всегда разделитель, если несколько номеров ГТД. Но также он используется в самом номере ГТД, и тут он должен быть сохранен (10115070/010419/0021408/010)
 

Допущения (Предположения, Основа ???):

1. Таблица начинается в строке 1
2. Данные начинаются в строке 2
3. Данные распознаются на основе фиксированного скелета (фиксированной основы)
4. Данные с повторяющимися номерами GTD симметричны
  Это значит что, номеров GTD столько же, сколько их аналогов с кодом страны и количеством ... и наоборот
5. В случае нескольких номеров GTD, исключений нет.
  Если, например, есть 3 номера GTD, то будет такое же количество кодов стран и названий стран, что и номера GTD.
  Схема есть схема, а не исключение от неё - "орднунг мусс зайн"

(как это будет работать с другими схемами данных не знаю)

Пс:
Вообще-то эта тема более для использования регулярных выражений - но, пожалуйста, попробуйте обычный код:

Код
Option Explicit

Sub abc_xyz()
Const sch1 = "*/*/*/*;[A-Z][A-Z]"
Const sch2 = "*/*/*/*, Q*.*;[A-Z][A-Z]"
Const sch3 = "*/*/*/*, Q*.*;*;[A-Z][A-Z], Q*.*;*"
    
    Dim i%, idx%, j%, jdx%, pos%
    Dim cntrstr$, gtdnr$, kodstr$, nzstr$, sstr$
    Dim rplc, splt, tbl, tblcntr, tblpos
    
    With Sheets("Country List").Range("A1").CurrentRegion
        tblcntr = .Offset(1, 0).Resize(.Rows.Count - 1, 3).Value
        tblpos = .Columns("B").Offset(1, 0).Resize(.Columns("B").Rows.Count - 1, 1).Value
    End With
    
    With Sheets("GTD").Range("A1").CurrentRegion.Columns("D")
        tbl = .Offset(1, 0).Resize(.Rows.Count - 1, 1).Value: idx = UBound(tbl, 1)
    End With
    
    For i = 1 To idx
        sstr = Replace(Replace(Trim(tbl(i, 1)), Chr(10), "", 1, -1, 1), Chr(13), "", 1, -1, 1)
        
        If sstr <> "" Then
            rplc = Replace(sstr, ",", ".", 1, -1, 1): sstr = ""
            rplc = Replace(rplc, "/[", ";", 1, -1, 1): rplc = Replace(rplc, "+", ";", 1, -1, 1)
            rplc = Replace(rplc, "]", ",", 1, -1, 1): rplc = Replace(rplc, "[", "", 1, -1, 1)
            rplc = Replace(rplc, ";EA", "", 1, -1, 1): rplc = Replace(rplc, ",;", ";", 1, -1, 1)
            If Right(rplc, 1) = "," Then rplc = Left(rplc, Len(rplc) - 1)
            rplc = Replace(rplc, ",", ", ", 1, -1, 1)
            
            splt = Split(rplc, ";", -1, 1)
            
            If Not IsEmpty(splt) Then
                If rplc Like sch1 Or rplc Like sch2 Then
                    pos = Application.Match(splt(1), tblpos, 0)
                    If Not IsError(pos) Then
                        If InStr(1, splt(0), ",", 1) > 0 Then sstr = "," & Split(splt(0), ",", -1, 1)(1)
                        nzstr = Application.Index(tblcntr, pos, 1) & sstr
                        kodstr = Application.Index(tblcntr, pos, 3)
                        splt = Array(splt(0), kodstr, nzstr)
                    End If
                    pos = 0: If sstr <> "" Then sstr = ""
                    
                ElseIf rplc Like sch3 Then
                    jdx = UBound(splt) \ 2
                    For j = 0 To jdx
                        gtdnr = gtdnr & splt(j) & ";" & Chr(10)
                        If InStr(1, splt(jdx + j + 1), ",", 1) > 0 Then
                            cntrstr = Split(splt(jdx + j + 1), ",", -1, 1)(0)
                            pos = Application.Match(cntrstr, tblpos, 0)
                            If Not IsError(pos) Then
                                nzstr = Application.Index(tblcntr, pos, 1)
                                sstr = sstr & Replace(splt(jdx + j + 1), cntrstr, nzstr, 1, -1, 1) & ";" & Chr(10)
                                kodstr = kodstr & Application.Index(tblcntr, pos, 3) & ";" & Chr(10)
                            End If
                            cntrstr = "": pos = 0
                        End If
                    Next
                    splt = Array(Left(gtdnr, Len(gtdnr) - 2), Left(kodstr, Len(kodstr) - 2), Left(sstr, Len(sstr) - 2))
                    
                End If
            End If
        End If
        
        If IsEmpty(rplc) Then splt = Array("'-", "'-", "'-") Else rplc = Empty
        Sheets("GTD").Range("E" & i + 1).Resize(1, 3).Value = splt: splt = Empty
        If gtdnr <> "" Then gtdnr = ""
        If sstr <> "" Then sstr = ""
        If kodstr <> "" Then kodstr = ""
    Next
    
    tbl = Empty: tblcntr = Empty: tblpos = Empty
End Sub

 
Цитата
Мария - написал:
я бы воспользовалась формулой SEARCH, но у меня возникает проблема, когда в одной строке несколько номеров и все они должны быть указаны
Так воспользуйтесь формулой "Мария" (надеюсь, знаете про то, как вводить формулы массива).
Скрытый текст
Изменено: aequit - 07.02.2020 14:52:28
Страницы: 1
Наверх