API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Aug 24th, 2017
905
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 15.50 KB | None | 0 0
raw download clone embed print report
  1. Sub поискмультивсякпроб1()
  2.  
  3.  
  4.  
  5. Dim иск2(50) As String
  6. Dim f(20) As String
  7. Dim FF(2000, 4) As String
  8. Dim zz As Integer
  9. Dim знач As Integer
  10. Sheets("поиск").Select
  11. Columns("B:AI").Select
  12. Selection.Delete Shift:=xlToLeft
  13. Range("B1").Select
  14. zz = 1
  15. While pust < 10
  16. pust = 1
  17. If (Trim(Sheets("поиск").Cells(zz, 1).Value)) = "" Then
  18. For i = 1 To 10
  19. If (Trim(Sheets("поиск").Cells(zz + i, 1).Value)) = "" Then
  20. pust = pust + 1
  21. End If
  22. Next
  23.  
  24. End If
  25. zz = zz + 1
  26. Wend
  27. столб1 = zz
  28. zz = 1
  29. Sheets("поиск").Cells(1, 3) = ""
  30. Sheets("поиск").Cells(2, 3) = ""
  31. Sheets("поиск").Cells(3, 3) = ""
  32. Sheets("поиск").Cells(4, 3) = ""
  33.  
  34.  
  35. While (zz <= столб1 Or zz <= 2)
  36. искомый = UCase(Trim(Sheets("поиск").Cells(zz, 1).Value))
  37. If искомый > "" Then
  38. L = Len(искомый)
  39. inst = InStr(1, искомый, Х)
  40. If искомый Like "*#X#*" Or искомый Like "*#Х#*" Then
  41. inst = InStr(1, искомый, Х)
  42. этотак = 1
  43. End If
  44.  
  45. nm = 1
  46. i1 = 0
  47. j = 1
  48. предцифра = ""
  49. предбуква = ""
  50. предпробел = ""
  51.  
  52. Do Until j > L
  53. иск = UCase(Mid(искомый, j, 1))
  54. kN = Asc(иск)
  55.  
  56. буква = ((90 >= kN And kN >= 65) Or (122 >= kN And kN >= 97) Or (255 >= kN And kN >= 192)) And kN <> 88 And kN <> 213
  57. цифра = (57 >= kN And kN >= 48)
  58. If цифра Or буква Then
  59.  
  60. If (90 >= kN And kN >= 65) Or (122 >= kN And kN >= 97) Then
  61.  
  62. имп = имп & "," & иск
  63.  
  64. End If
  65.  
  66. If (предцифра <> цифра Or предбуква <> буква) Then
  67. i1 = i1 + 1
  68.  
  69. End If
  70. иск2(i1) = иск2(i1) & иск
  71. Else:
  72. End If
  73.  
  74. j = j + 1
  75. предцифра = цифра
  76. предбуква = буква
  77. предпробел = пробел
  78.  
  79. Loop
  80. f(15) = "*"
  81. f(1) = UCase(искомый)
  82. f(5) = f(1) & " " & "*"
  83.  
  84. For k = 1 To i1
  85. f(14) = f(14) & иск2(k) & "*"
  86. f(4) = f(4) & иск2(k)
  87. If k = 2 Then
  88. f(2) = f(2) & "-"
  89. f(3) = f(3) & "?"
  90. End If
  91. f(2) = f(2) & иск2(k)
  92. f(3) = f(3) & иск2(k)
  93. Next
  94. f(7) = f(2) & "?"
  95. f(8) = f(2) & "??"
  96. f(9) = f(3) & "?"
  97. f(12) = f(3) & "??"
  98. f(11) = "*" & f(4) & "*"
  99. f(6) = f(2) & "*"
  100. f(13) = "*" & f(3) & "*"
  101. f(15) = "*" & f(14)
  102. Vall = Asc(" ")
  103.  
  104. 'и1 = "*" & иск(1) & "*" & иск(2) & "*" & иск(3) & "*" & иск(4) & "*"
  105.  
  106. '---------------------------------------
  107. j = Sheets("всяк").Index
  108. maxj = Sheets("ALMOS2").Index
  109. If искомый Like "Т1" Then
  110. обр = f(1)
  111. Else: обр = f(15)
  112. End If
  113.  
  114. gg = 1
  115. While j < maxj
  116.  
  117.  
  118.  
  119. i = 1
  120. ilstr = Worksheets(j).UsedRange.Row + Worksheets(j).UsedRange.Rows.count
  121. While i <> ilstr
  122.  
  123. x = UCase(Sheets(j).Cells(i, 1))
  124.  
  125.  
  126.  
  127.  
  128.  
  129. If x Like обр Then
  130. Sheets("поиск").Cells(listj, 2) = x
  131. нач = 1
  132. listj = 1
  133. igh = 1
  134. jh = 1
  135. 'рассм = x
  136. Do Until jh >= Len(x) Or igh > i1
  137.  
  138. lastmetka = metka
  139. metka = InStr([нач], x, иск2(igh))
  140.  
  141. If metka > lastmetka Then
  142.  
  143. нач = metka + 1
  144. igh = igh + 1
  145. 'рассм = Right(рассм, Len(рассм) - metka)
  146. If lastmetka > "" Then
  147. сумм = сумм + (metka - lastmetka - 1)
  148.  
  149. End If
  150. Sheets("поиск").Cells(listj, 3) = Left(x, metka)
  151. Sheets("поиск").Cells(listj, 4) = Right(x, Len(x) - metka)
  152. Sheets("поиск").Cells(listj, 2) = x
  153. End If
  154.  
  155. listj = listj + 1
  156. jh = jh + 1
  157. Loop
  158. срвзв = Val(сумм) / Val(igh)
  159. сумм = 0
  160. kk = 1
  161.  
  162. Do Until kk > 16 Or fin = 1
  163. If x Like f(kk) Then
  164. y = ""
  165. z = ""
  166.  
  167.  
  168. z = Sheets(j).Cells(i, 10)
  169.  
  170. y = Sheets(j).Cells(i, 11) & " " & Sheets(j).Cells(i, 2) & " " & Sheets(j).Cells(i, 5) & " " & Sheets(j).Cells(i, 12) & " шт" & " " & Sheets(j).Cells(i, 9) & " руб"
  171.  
  172.  
  173. If z = "якуб" Then
  174. x = x & " " & Sheets(j).Cells(i, 2) & " " & " " & Sheets(j).Cells(i, 3) & " шт" & " " & "по" & " " & Sheets(j).Cells(i, 4) & " руб"
  175. Else: x = x & " " & Sheets(j).Cells(i, 2) & " " & Sheets(j).Cells(i, 5) & " " & Sheets(j).Cells(i, 3) & " шт" & " " & "по" & " " & Sheets(j).Cells(i, 4) & " руб"
  176. End If
  177.  
  178.  
  179. If kk < kkpro Then
  180. stolb = 1
  181. rez1 = 0
  182. Do Until stolb = gg Or rez1 = 1
  183. знач = Val(FF(stolb, 2))
  184. If kk < знач Then
  185.  
  186. For iii = gg To stolb + 1 Step -1
  187. FF(iii, 2) = FF(iii - 1, 2)
  188. FF(iii, 1) = FF(iii - 1, 1)
  189. FF(iii, 3) = FF(iii - 1, 3)
  190. FF(iii, 4) = FF(iii - 1, 4)
  191. Next
  192. rez1 = 1
  193. FF(stolb, 1) = x
  194. FF(stolb, 2) = kk
  195. FF(stolb, 3) = y
  196. FF(stolb, 4) = z
  197. End If
  198. stolb = stolb + 1
  199. Loop
  200.  
  201. Else:
  202. FF(gg, 1) = x
  203. FF(gg, 2) = kk
  204. FF(gg, 3) = y
  205. FF(gg, 4) = z
  206. kkpro = kk
  207. End If
  208.  
  209.  
  210. gg = gg + 1
  211. fin = 1
  212.  
  213. End If
  214. kk = kk + 1
  215. Loop
  216. fin = 0
  217.  
  218.  
  219.  
  220.  
  221. End If
  222.  
  223. i = i + 1
  224. Wend
  225. j = j + 1
  226. Wend
  227. If имп > "" Then
  228.  
  229. Sheets("поиск").Cells(pp + 6, 4) = "Результат поиска для " & искомый & " :" & " импортные буквы " & имп
  230. имп = ""
  231. Else: Sheets("поиск").Cells(pp + 6, 4) = "Результат поиска для " & искомый & " :"
  232. End If
  233. If gg = 1 Then
  234. End If
  235. For m = 1 To gg - 1
  236. Sheets("поиск").Cells(m + pp + 6, 4) = FF(m, 1)
  237. FF(m, 1) = ""
  238. Sheets("поиск").Cells(m + pp + 6, 3) = FF(m, 2)
  239. FF(m, 2) = ""
  240. Sheets("поиск").Cells(m + pp + 6, 5) = FF(m, 3)
  241. FF(m, 3) = ""
  242. text1 = FF(m, 4)
  243.  
  244.  
  245.  
  246.  
  247. Select Case text1
  248.  
  249. Case "астинг"
  250. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:ASTING <asting1@mail.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе"", ""астинг"" )"
  251.  
  252. Case "васябел"
  253. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Vasya <vvvmc2@gmail.com>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе"", ""всмн"" )"
  254.  
  255. Case "stell@vitebsk.by_эл"
  256. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:ZHANNA <stell@vitebsk.by> (СТЭЛЛ)?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""СТ"" )"
  257.  
  258. Case "anatol74@bk.ru"
  259. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Мельник Александр <anatol74@bk.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""асд"" )"
  260.  
  261. Case "<ppm@online.ru>"
  262. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Игорь. <stip@semitex.ru> (semitex)?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""И"" )"
  263.  
  264. Case "алексейр6"
  265. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Алексей Пестов <lexapuch@mail.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""Р6"" )"
  266.  
  267. Case "якуб"
  268. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:ЯКУБ <ar9166688629@yandex.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""Я"" )"
  269.  
  270. Case "васком"
  271. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Сергей <sergey.mil-36.73@mail.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""вскм"" )"
  272.  
  273. Case "бойко"
  274. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Иван <radiodet01@gmail.com>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""Б"" )"
  275.  
  276. Case "vadem"
  277. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Malahia <malahia2009@gmail.com>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""вдм"" )"
  278.  
  279. Case "влмн"
  280. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Владимир <vvi@rdkom.net>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""влмн"" )"
  281.  
  282. Case "устинов"
  283. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Andrey <japanavt@gmail.com>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""уст"" )"
  284.  
  285. Case "nikkkolay@elnet.msk.ru"
  286. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:RADIO-PROM <radioprom@bk.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""рпр"" )"
  287.  
  288. Case "гера"
  289. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Гера <ger@cbx.ru,yardikov@yandex.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""г"" )"
  290.  
  291.  
  292. Case "самарин"
  293. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Самарин Андрей <anvisam@gmail.com>"",""смрн"" )"
  294.  
  295. Case "примула"
  296. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Радио-Примула <rp@kitco.su>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""прим"" )"
  297.  
  298. Case "edik-serp@mail.ru"
  299. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Эдуард Алов <edik-serp@mail.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""эд"" )"
  300.  
  301. Case "иванбел"
  302. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Иван <ivans.003@gmail.com>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""ивбл"" )"
  303.  
  304. Case "sashayura@mail.ru"
  305. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Глазков Александр <glazkovradio@yandex.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""гл"" )"
  306.  
  307. Case "соколов"
  308. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:михаил соколов <masradio@mail.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""мсок"" )"
  309.  
  310. Case "sam"
  311. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Михаил <sam251977@alexandrov.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""мсв"" )"
  312.  
  313. Case "sasha@dvina-rd.ru"
  314. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Заказ Двина <zakaz@radiocub.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""дв"" )"
  315.  
  316.  
  317. Case "nika@suvorov.tula.net"
  318. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Александр Никифоров <nika@suvorov.tula.net>"",""тл"" )"
  319.  
  320. Case "сергей"
  321. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Сергей <serg401@rambler.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""ресрг"" )"
  322.  
  323. Case "Fantom <186750@mail.ru>"
  324. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Fantom <186750@mail.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""юраф"" )"
  325.  
  326. Case "травкин"
  327. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Травкин Александр <alex-mitino@yandex.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""трв"" )"
  328.  
  329. Case "info@radiodetali.in.ua"
  330. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Фурман Александр <info@radiodetali.in.ua>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""фрм"" )"
  331.  
  332. Case "stell@vitebsk.by_рад"
  333. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:ZHANNA <stell@vitebsk.by> (СТЭЛЛ)?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""ст"" )"
  334.  
  335. Case "infels@mail.ru"
  336. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Infelservice <infels@mail.ru> (Infelservice)?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""инф"" )"
  337.  
  338. Case "алик"
  339. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Алик Наумов <merkil@mail.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""алк"" )"
  340.  
  341. Case "ксанф"
  342. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:sales@ksanf.spb.ru?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""ксанф"" )"
  343.  
  344. Case "антелеком"
  345. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Наталья <info@antelcom.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""антелеком"" )"
  346.  
  347. Case "myrashkinm@mail.ru"
  348. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:myrashkinm@mail.ru?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""myrashkinm@mail.ru"" )"
  349.  
  350. Case "186750@mail.ru"
  351. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Юра <186750@mail.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""Фантом Юра"" )"
  352.  
  353. Case "владислав"
  354. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Электроавтоматика <radiodetali33@yandex.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""Электроавтоматика владислав"" )"
  355. Case "kmp62@mail.ru"
  356. Sheets("поиск").Cells(m + pp + 6, 6).Formula = "=HYPERLINK(""mailto:Михаил Петрович Коротин <kmp62@mail.ru>?subject=Re: ИНТЕРЕСУЕТ в вашем прайсе "",""Коротин <kmp62@mail.ru>"" )"
  357.  
  358.  
  359. Case Else:
  360. Sheets("поиск").Cells(m + pp + 6, 6) = text1
  361. End Select
  362.  
  363.  
  364.  
  365.  
  366.  
  367.  
  368. FF(m, 4) = ""
  369. Next
  370. pp = pp + m + 1
  371.  
  372. For ii = 1 To 15
  373. f(ii) = ""
  374. иск2(ii) = ""
  375. Next
  376. kkpro = 1
  377. gg = 0
  378.  
  379. End If
  380. zz = zz + 1
  381. Wend
  382. Columns("A:A").ColumnWidth = 15
  383.  
  384. Columns("B:B").ColumnWidth = 0.5
  385. Columns("C:C").ColumnWidth = 2
  386. Columns("D:D").ColumnWidth = 30
  387. Columns("E:E").ColumnWidth = 30
  388. Cells.Select
  389. With Selection.Font
  390. .Name = "Arial Cyr"
  391. .Size = 7
  392. .Strikethrough = False
  393. .Superscript = False
  394. .Subscript = False
  395. .OutlineFont = False
  396. .Shadow = False
  397. .Underline = xlUnderlineStyleNone
  398. .ColorIndex = xlAutomatic
  399. End With
  400. Columns("A:A").Select
  401. With Selection.Font
  402. .Name = "Arial Cyr"
  403. .Size = 8
  404. .Strikethrough = False
  405. .Superscript = False
  406. .Subscript = False
  407. .OutlineFont = False
  408. .Shadow = False
  409. .Underline = xlUnderlineStyleNone
  410. .ColorIndex = xlAutomatic
  411. End With
  412. Range("C1").Select
  413.  
  414.  
  415. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!