Advertisement
Guest User

Untitled

a guest
Jul 18th, 2017
68
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub AddCLientNew()
  2. Dim wb As Workbook
  3. Dim ws As Worksheet
  4. Set wb = ActiveWorkbook
  5. Set ws = wb.Sheets(1)
  6. Dim allPerson As String
  7. Dim allPersonArray() As String
  8. 'Sprawdzenie czy Q1 nie jest puste
  9. If IsEmpty(ws.Range("Q1")) Then
  10.    
  11.     If IsEmpty(ws.Range("R1")) Then
  12.         MsgBox "Podaj dane!"
  13.     Else
  14.        
  15.             allPerson = LoadFromFile(ws.Range("R1"))
  16.             allPersonArray = Split(allPerson, """" + Chr(10) + """")
  17.             For i = 0 To (UBound(allPersonArray))
  18.              addPerson (allPersonArray(i))
  19.             Next i
  20.             Flname = InputBox("Enter File Name :", "Creating New File...")
  21.              If Flname <> "" Then
  22.             Set NewWkbk = Workbooks.Add
  23.             ws.Copy Before:=NewWkbk.Sheets(1)
  24.             NewWkbk.Sheets(1).Shapes("asd").Delete
  25.             NewWkbk.Sheets(1).Shapes("asd").Delete
  26.             NewWkbk.Sheets(1).Range("Q1").Interior.ColorIndex = 0
  27.             NewWkbk.Sheets(1).Range("R1").Interior.ColorIndex = 0
  28.             NewWkbk.Sheets(1).Range("Q1").Value = vbNullString
  29.             NewWkbk.Sheets(1).Range("R1").Value = vbNullString
  30.             NewWkbk.SaveAs ThisWorkbook.path & "\" & Flname
  31.             'Wyczyszczenie Q1
  32.            ws.Range("Q1").Value = vbNullString
  33.         End If
  34.     End If
  35. Else
  36.    
  37.         allPerson = ws.Range("Q1").Text
  38.         allPersonArray = Split(allPerson, """" + Chr(10) + """")
  39.         For i = 0 To (UBound(allPersonArray))
  40.          addPerson (allPersonArray(i))
  41.         Next i
  42.         Flname = InputBox("Enter File Name :", "Creating New File...")
  43.     If Flname <> "" Then
  44.         Set NewWkbk = Workbooks.Add
  45.            ws.Copy Before:=NewWkbk.Sheets(1)
  46.             NewWkbk.Sheets(1).Shapes("asd").Delete
  47.            NewWkbk.Sheets(1).Range("Q1").Interior.ColorIndex = 0
  48.             NewWkbk.Sheets(1).Range("R1").Interior.ColorIndex = 0
  49.             NewWkbk.Sheets(1).Range("Q1").Value = vbNullString
  50.             NewWkbk.Sheets(1).Range("R1").Value = vbNullString
  51.            
  52.             NewWkbk.SaveAs ThisWorkbook.path & "\" & Flname
  53.         'Wyczyszczenie Q1
  54.        ws.Range("Q1").Value = vbNullString
  55.     End If
  56. End If
  57.  
  58. End Sub
  59. Sub AddClients()
  60.  
  61.  
  62. Dim wb As Workbook
  63. Dim ws As Worksheet
  64. Set wb = ActiveWorkbook
  65. Set ws = wb.Sheets(1)
  66. Dim allPerson As String
  67. Dim allPersonArray() As String
  68. 'Sprawdzenie czy Q1 nie jest puste
  69. If IsEmpty(ws.Range("Q1")) Then
  70.    
  71.     If IsEmpty(ws.Range("R1")) Then
  72.         MsgBox "Podaj dane!"
  73.     Else
  74.        
  75.             allPerson = LoadFromFile(ws.Range("R1"))
  76.             allPersonArray = Split(allPerson, """" + Chr(10) + """")
  77.             For i = 0 To (UBound(allPersonArray))
  78.              addPerson (allPersonArray(i))
  79.             Next i
  80.            
  81.             ws.Range("Q1").Value = vbNullString
  82.      
  83.     End If
  84. Else
  85.    
  86.         allPerson = ws.Range("Q1").Text
  87.         allPersonArray = Split(allPerson, """" + Chr(10) + """")
  88.         For i = 0 To (UBound(allPersonArray))
  89.          addPerson (allPersonArray(i))
  90.         Next i
  91.    
  92.         'Wyczyszczenie Q1
  93.        ws.Range("Q1").Value = vbNullString
  94.     End If
  95.  
  96.  
  97.  
  98. End Sub
  99.  
  100.  
  101. Function addPerson(person As String)
  102. Dim wb As Workbook
  103. Dim ws As Worksheet
  104. Set wb = ActiveWorkbook
  105. Set ws = wb.Sheets(1)
  106. 'Znalezienie pierwszego wolnego wiersza
  107. Dim fbr As String
  108. fbr = firstBlankRow(ws)
  109.  
  110. 'Usuniecie niepotrzebnych enterow i podwojnego "
  111. person = Replace(person, Chr(10) + Chr(10), vbNullString)
  112. person = Replace(person, Chr(34) + Chr(34), vbNullString)
  113. 'Usuniecie potencjalnych danych do faktury
  114. If InStr(person, "Dane do faktury:") > 0 Then
  115.     person = Left(person, InStr(person, "Dane do faktury:") - 1)
  116. End If
  117. 'Usuniecie potenjalnej Polski
  118. If InStr(person, "Polska") > 0 Then
  119.     person = Replace(person, "Polska", vbNullString)
  120. End If
  121. 'Zlapanie telefonu
  122. Dim tel As String
  123. Dim kurwaOgarnijTelCzyTelefon As String
  124. If (InStr(UCase(person), "TELEFON") > 0 Or InStr(UCase(person), "TEL") > 0) Then
  125.     If InStr(UCase(person), "TELEFON") Then
  126.         kurwaOgarnijTelCzyTelefon = "TELEFON"
  127.     Else
  128.         kurwaOgarnijTelCzyTelefon = "TEL"
  129.     End If
  130.     tel = Mid(person, InStr(UCase(person), kurwaOgarnijTelCzyTelefon) - 1, 100)
  131.     tel = Replace(tel, "Telefon", vbNullString)
  132.     tel = Replace(tel, "Tel", vbNullString)
  133.     tel = Replace(tel, " ", vbNullString)
  134. Else
  135.     Dim test As Long
  136.     test = MYMATCH(person, "([ ]?[\+]?[ ]?([0-9]{0}|[0-9]{2})?[ ]?[\-]?[ ]?[\(]?[ ]?[0-9]{3}[ ]?[\)]?[ ]?[\-]?[ ]?[0-9]{3}[ ]?[\-]?[ ]?[0-9]{3}[ ]?)|([ ]?[\+]?[ ]?[\(]?[0-9]{2}[\)]?[0-9]{7})")
  137.     If test > 0 Then
  138.         tel = Mid(person, test, 100)
  139.     Else
  140.         MsgBox ("Osoba posiada nieprawidlowy numer!" + Chr(10) + Chr(10) + person)
  141.         tel = vbNullString
  142.     End If
  143. End If
  144. 'Usuniecie telefonu z person
  145. Dim test1 As Long
  146. test1 = MYMATCH(person, "([ ]?[\+]?[ ]?([0-9]{0}|[0-9]{2})?[ ]?[\-]?[ ]?[\(]?[ ]?[0-9]{3}[ ]?[\)]?[ ]?[\-]?[ ]?[0-9]{3}[ ]?[\-]?[ ]?[0-9]{3}[ ]?)|([ ]?[\+]?[ ]?[\(]?[0-9]{2}[\)]?[0-9]{7})")
  147. If test1 > 0 Then
  148.     person = Mid(person, 1, test1)
  149. End If
  150. person = Replace(person, "Telefon", vbNullString)
  151. person = Replace(person, "Tel", vbNullString)
  152. person = Replace(person, tel, vbNullString)
  153. 'Zlapanie kodu i miasta
  154. Dim kodMiasto As String
  155. kodMiasto = Mid(person, MYMATCH(person, "[0-9]{2}[ ]?[\-][ ]?[0-9]{3}"), 100)
  156. Dim kod As String
  157. kod = Mid(kodMiasto, MYMATCH(kodMiasto, "[0-9]{2}[ ]?[\-][ ]?[0-9]{3}"), 6)
  158. Dim miasto As String
  159. miasto = Replace(kodMiasto, kod, vbNullString)
  160. 'Usuniecie kodu i miasta z person
  161. person = Replace(person, kodMiasto, vbNullString)
  162. 'Zlapanie adresu(jako ostatniej linijki obecnego person)
  163. Dim adres As String
  164. Dim tempArray() As String
  165. tempArray = Split(person, Chr(10))
  166. adres = tempArray(UBound(tempArray) - 1)
  167. 'Usuniecie adresu z person (teraz person to odbiorca)
  168. person = Replace(person, adres, vbNullString)
  169. 'Wstawianie wartosci w pola
  170. ws.Range("A" + fbr).Value = Replace(Replace(person, Chr(10), vbNullString), Chr(34), vbNullString)
  171. ws.Range("C" + fbr).Value = Replace(Replace(tel, Chr(10), vbNullString), Chr(34), vbNullString)
  172. ws.Range("E" + fbr).Value = Replace(Replace(adres, Chr(10), vbNullString), Chr(34), vbNullString)
  173. ws.Range("F" + fbr).Value = Replace(Replace(miasto, Chr(10), vbNullString), Chr(34), vbNullString)
  174. ws.Range("G" + fbr).Value = Replace(Replace(kodMiasto, Chr(10), vbNullString), Chr(34), vbNullString)
  175. ws.Range("H" + fbr).Value = "PL"
  176. ws.Range("I" + fbr).Value = "1"
  177. ws.Range("J" + fbr).Value = "4"
  178. ws.Range("O" + fbr).Value = """Książki" + vbCrLf + "------" + vbCrLf + "www.podsowa.pl"""
  179.  
  180. End Function
  181.  
  182. Function firstBlankRow(ws As Worksheet) As Long
  183. 'returns the row # of the row after the last used row
  184. 'Or the first row with no data in it
  185.    Dim rw As Range
  186.     For Each rw In ws.UsedRange.Rows
  187.         If rw.Address = ws.Range(rw.Address).SpecialCells(xlCellTypeBlanks). _
  188.             Address Then
  189.  
  190.                 firstBlankRow = rw.Row
  191.                 Exit For
  192.         End If
  193.     Next
  194.     If firstBlankRow = 0 Then
  195.         firstBlankRow = ws.Cells.SpecialCells(xlCellTypeLastCell). _
  196.                     Offset(1, 0).Row - 3
  197.     End If
  198.  
  199. End Function
  200. Function MYMATCH(strValue As String, strPattern As String, Optional blnCase As Boolean = True, Optional blnBoolean = True) As String
  201.     Dim objRegEx As Object
  202.     Dim strPosition As Integer
  203.     Dim RegMC
  204.  
  205.     ' Create regular expression.
  206.    Set objRegEx = CreateObject("VBScript.RegExp")
  207.     With objRegEx
  208.         .Pattern = strPattern
  209.         .IgnoreCase = blnCase
  210.         If .test(strValue) Then
  211.             Set RegMC = .Execute(strValue)
  212.             MYMATCH = RegMC(0).firstindex + 1
  213.         Else
  214.             MYMATCH = 0
  215.         End If
  216.     End With
  217. End Function
  218.  
  219. Function LoadFromFile(filePath As String) As String
  220. Open filePath For Input As #1
  221. Dim Total As String
  222. While EOF(1) = False
  223.     Line Input #1, strLine
  224.     Total = Total & vbNewLine & strLine
  225.     i = i + 1
  226. Wend
  227. LoadFromFile = Total
  228. Close #1
  229. End Function
  230.  
  231. Function CheckCountry(country As String) As Integer
  232. Dim countries() As String
  233. countries = Array("Albania", "Andora", "Austria", "Belgia", "Białoruś", "Bośnia i Hercegowina", "Bułgaria", "Chorwacja", "Cypr", "Czarnogóra", "Czechy", "Dania", "Estonia", "Finlandia", "Francja", "Gibraltar", "Grecja", "Gruzja", "Hiszpania", "Holandia", "Irlandia", "Islandia", "Kazachstan", "Liechtenstein", "Litwa", "Luksemburg", "Łotwa", "Macedonia", "Malta", "Monako", "Mołdawia", "Niemcy", "Norwegia", "Polska", "Portugalia", "Rosja", "Rumunia", "San Marino", "Serbia", "Szwajcaria", "Szwecja", "Słowacja", "Słowenia", "Turcja", "Ukraina", "Watykan", "WielkaBrytania", "Węgry", "Włochy")
  234.  
  235. End Function
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement