Доброго времени суток, Знатоки! Очень нужна помощь в написании VBA кода.
Имеем Номер ГТД и Страну в разных форматах (колонка GTD Info), нужно информацию в одной колонке разделить на 3
например, имеем [10009190/190819/0003170/006]+[IT] в колонке GTD No должно быть 10009190/190819/0003170/006 в колонке Country No (ISO) должно быть 380 в колонке Country Name должно быть Италия
во вложенном файле есть пример того, как должны быть заполнены колонки. а также на листе Country List - данные по странам, на основании которых должны заполняться колонки я бы воспользовалась формулой SEARCH, но у меня возникает проблема, когда в одной строке несколько номеров и все они должны быть указаны
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 как должно быть. При этом, если двойным щелчком раскрыть строку, чтобы каждый номер был на новой строке в ячейке, все работает нормально. еще вопрос по строкам, когда одна ГТД и не указано количество. после указания страны стоит ",".
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, но у меня возникает проблема, когда в одной строке несколько номеров и все они должны быть указаны
Так воспользуйтесь формулой "Мария" (надеюсь, знаете про то, как вводить формулы массива).
Скрытый текст
Код
Option Explicit
Function Мария(strTxt As String) As Variant
Dim a$, b$, c$, p$, v, i&, j&
Dim sКод$, sСтрана$, ar(2)
Static arrCountry()
If Not (Not Not arrCountry) > 0 Then
arrCountry = Worksheets("Country List").Range("A2:C252").Value
End If
strTxt = Replace(strTxt, " ", "")
strTxt = Replace(strTxt, Chr(10), "")
p = "\/(?=[^\[\])]*\[)"
strTxt = RegExPRepl(strTxt, p, "; " & Chr(10))
p = "(.+)(\+)(KAR|EA)"
strTxt = RegExPRepl(strTxt, p, "$1")
p = "([\S\s]+)(\+)([\S\s]+)"
a = RegExPRepl(strTxt, p, "$1")
b = RegExPRepl(strTxt, p, "$3")
a = Replace(Replace(a, "[", ""), "]", ", ")
If InStr(b, Chr(10)) > 0 Then
v = Split(b, Chr(10))
For j = 0 To UBound(v)
v(j) = Trim(v(j))
b = Replace(Replace(v(j), "[", ""), "]", "")
b = Replace(Replace(b, Chr(13), ""), Chr(10), "")
For i = 1 To UBound(arrCountry, 1)
If Left(b, 2) = arrCountry(i, 2) Then
sКод = sКод & arrCountry(i, 3) & ";" & Chr(10)
sСтрана = sСтрана & arrCountry(i, 1) & ", " & Mid(b, 3) & Chr(10)
Exit For
End If
Next i
Next j
p = "([\S\s]+)(\n{1,2}|[,;] ?)$"
ar(0) = RegExPRepl(a, p, "$1")
sКод = Trim(RegExPRepl(sКод, p, "$1"))
ar(1) = RegExPRepl(sКод, p, "$1")
ar(2) = Trim(RegExPRepl(sСтрана, p, "$1"))
Else
b = Replace(Replace(b, "[", ""), "]", "")
For i = 1 To UBound(arrCountry, 1)
If b = arrCountry(i, 2) Then
sКод = arrCountry(i, 3)
sСтрана = arrCountry(i, 1)
Exit For
End If
Next i
p = "([\S\s]+)([,;] ?)$"
ar(0) = RegExPRepl(a, p, "$1")
ar(1) = RegExPRepl(sКод, p, "$1")
ar(2) = RegExPRepl(sСтрана, p, "$1")
End If
Мария = ar
End Function
Function RegExPRepl(sString$, sFind$, sReplace$, Optional bIgnoreCase As Boolean = False, Optional bGlobal As Boolean = True, _
Optional bMultiLine As Boolean = True) As String
Static RegEx As RegExp
If RegEx Is Nothing Then Set RegEx = New RegExp
With RegEx
.Global = bGlobal
.Multiline = bMultiLine
.IgnoreCase = bIgnoreCase
.Pattern = sFind
End With
RegExPRepl = RegEx.Replace(sString, sReplace)
End Function