Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Sub AddCLientNew()
- Dim wb As Workbook
- Dim ws As Worksheet
- Set wb = ActiveWorkbook
- Set ws = wb.Sheets(1)
- Dim allPerson As String
- Dim allPersonArray() As String
- 'Sprawdzenie czy Q1 nie jest puste
- If IsEmpty(ws.Range("Q1")) Then
- If IsEmpty(ws.Range("R1")) Then
- MsgBox "Podaj dane!"
- Else
- allPerson = LoadFromFile(ws.Range("R1"))
- allPersonArray = Split(allPerson, """" + Chr(10) + """")
- For i = 0 To (UBound(allPersonArray))
- addPerson (allPersonArray(i))
- Next i
- Flname = InputBox("Enter File Name :", "Creating New File...")
- If Flname <> "" Then
- Set NewWkbk = Workbooks.Add
- ws.Copy Before:=NewWkbk.Sheets(1)
- NewWkbk.Sheets(1).Shapes("asd").Delete
- NewWkbk.Sheets(1).Shapes("asd").Delete
- NewWkbk.Sheets(1).Range("Q1").Interior.ColorIndex = 0
- NewWkbk.Sheets(1).Range("R1").Interior.ColorIndex = 0
- NewWkbk.Sheets(1).Range("Q1").Value = vbNullString
- NewWkbk.Sheets(1).Range("R1").Value = vbNullString
- NewWkbk.SaveAs ThisWorkbook.path & "\" & Flname
- 'Wyczyszczenie Q1
- ws.Range("Q1").Value = vbNullString
- End If
- End If
- Else
- allPerson = ws.Range("Q1").Text
- allPersonArray = Split(allPerson, """" + Chr(10) + """")
- For i = 0 To (UBound(allPersonArray))
- addPerson (allPersonArray(i))
- Next i
- Flname = InputBox("Enter File Name :", "Creating New File...")
- If Flname <> "" Then
- Set NewWkbk = Workbooks.Add
- ws.Copy Before:=NewWkbk.Sheets(1)
- NewWkbk.Sheets(1).Shapes("asd").Delete
- NewWkbk.Sheets(1).Range("Q1").Interior.ColorIndex = 0
- NewWkbk.Sheets(1).Range("R1").Interior.ColorIndex = 0
- NewWkbk.Sheets(1).Range("Q1").Value = vbNullString
- NewWkbk.Sheets(1).Range("R1").Value = vbNullString
- NewWkbk.SaveAs ThisWorkbook.path & "\" & Flname
- 'Wyczyszczenie Q1
- ws.Range("Q1").Value = vbNullString
- End If
- End If
- End Sub
- Sub AddClients()
- Dim wb As Workbook
- Dim ws As Worksheet
- Set wb = ActiveWorkbook
- Set ws = wb.Sheets(1)
- Dim allPerson As String
- Dim allPersonArray() As String
- 'Sprawdzenie czy Q1 nie jest puste
- If IsEmpty(ws.Range("Q1")) Then
- If IsEmpty(ws.Range("R1")) Then
- MsgBox "Podaj dane!"
- Else
- allPerson = LoadFromFile(ws.Range("R1"))
- allPersonArray = Split(allPerson, """" + Chr(10) + """")
- For i = 0 To (UBound(allPersonArray))
- addPerson (allPersonArray(i))
- Next i
- ws.Range("Q1").Value = vbNullString
- End If
- Else
- allPerson = ws.Range("Q1").Text
- allPersonArray = Split(allPerson, """" + Chr(10) + """")
- For i = 0 To (UBound(allPersonArray))
- addPerson (allPersonArray(i))
- Next i
- 'Wyczyszczenie Q1
- ws.Range("Q1").Value = vbNullString
- End If
- End Sub
- Function addPerson(person As String)
- Dim wb As Workbook
- Dim ws As Worksheet
- Set wb = ActiveWorkbook
- Set ws = wb.Sheets(1)
- 'Znalezienie pierwszego wolnego wiersza
- Dim fbr As String
- fbr = firstBlankRow(ws)
- 'Usuniecie niepotrzebnych enterow i podwojnego "
- person = Replace(person, Chr(10) + Chr(10), vbNullString)
- person = Replace(person, Chr(34) + Chr(34), vbNullString)
- 'Usuniecie potencjalnych danych do faktury
- If InStr(person, "Dane do faktury:") > 0 Then
- person = Left(person, InStr(person, "Dane do faktury:") - 1)
- End If
- 'Usuniecie potenjalnej Polski
- If InStr(person, "Polska") > 0 Then
- person = Replace(person, "Polska", vbNullString)
- End If
- 'Zlapanie telefonu
- Dim tel As String
- Dim kurwaOgarnijTelCzyTelefon As String
- If (InStr(UCase(person), "TELEFON") > 0 Or InStr(UCase(person), "TEL") > 0) Then
- If InStr(UCase(person), "TELEFON") Then
- kurwaOgarnijTelCzyTelefon = "TELEFON"
- Else
- kurwaOgarnijTelCzyTelefon = "TEL"
- End If
- tel = Mid(person, InStr(UCase(person), kurwaOgarnijTelCzyTelefon) - 1, 100)
- tel = Replace(tel, "Telefon", vbNullString)
- tel = Replace(tel, "Tel", vbNullString)
- tel = Replace(tel, " ", vbNullString)
- Else
- Dim test As Long
- test = MYMATCH(person, "([ ]?[\+]?[ ]?([0-9]{0}|[0-9]{2})?[ ]?[\-]?[ ]?[\(]?[ ]?[0-9]{3}[ ]?[\)]?[ ]?[\-]?[ ]?[0-9]{3}[ ]?[\-]?[ ]?[0-9]{3}[ ]?)|([ ]?[\+]?[ ]?[\(]?[0-9]{2}[\)]?[0-9]{7})")
- If test > 0 Then
- tel = Mid(person, test, 100)
- Else
- MsgBox ("Osoba posiada nieprawidlowy numer!" + Chr(10) + Chr(10) + person)
- tel = vbNullString
- End If
- End If
- 'Usuniecie telefonu z person
- Dim test1 As Long
- test1 = MYMATCH(person, "([ ]?[\+]?[ ]?([0-9]{0}|[0-9]{2})?[ ]?[\-]?[ ]?[\(]?[ ]?[0-9]{3}[ ]?[\)]?[ ]?[\-]?[ ]?[0-9]{3}[ ]?[\-]?[ ]?[0-9]{3}[ ]?)|([ ]?[\+]?[ ]?[\(]?[0-9]{2}[\)]?[0-9]{7})")
- If test1 > 0 Then
- person = Mid(person, 1, test1)
- End If
- person = Replace(person, "Telefon", vbNullString)
- person = Replace(person, "Tel", vbNullString)
- person = Replace(person, tel, vbNullString)
- 'Zlapanie kodu i miasta
- Dim kodMiasto As String
- kodMiasto = Mid(person, MYMATCH(person, "[0-9]{2}[ ]?[\-][ ]?[0-9]{3}"), 100)
- Dim kod As String
- kod = Mid(kodMiasto, MYMATCH(kodMiasto, "[0-9]{2}[ ]?[\-][ ]?[0-9]{3}"), 6)
- Dim miasto As String
- miasto = Replace(kodMiasto, kod, vbNullString)
- 'Usuniecie kodu i miasta z person
- person = Replace(person, kodMiasto, vbNullString)
- 'Zlapanie adresu(jako ostatniej linijki obecnego person)
- Dim adres As String
- Dim tempArray() As String
- tempArray = Split(person, Chr(10))
- adres = tempArray(UBound(tempArray) - 1)
- 'Usuniecie adresu z person (teraz person to odbiorca)
- person = Replace(person, adres, vbNullString)
- 'Wstawianie wartosci w pola
- ws.Range("A" + fbr).Value = Replace(Replace(person, Chr(10), vbNullString), Chr(34), vbNullString)
- ws.Range("C" + fbr).Value = Replace(Replace(tel, Chr(10), vbNullString), Chr(34), vbNullString)
- ws.Range("E" + fbr).Value = Replace(Replace(adres, Chr(10), vbNullString), Chr(34), vbNullString)
- ws.Range("F" + fbr).Value = Replace(Replace(miasto, Chr(10), vbNullString), Chr(34), vbNullString)
- ws.Range("G" + fbr).Value = Replace(Replace(kodMiasto, Chr(10), vbNullString), Chr(34), vbNullString)
- ws.Range("H" + fbr).Value = "PL"
- ws.Range("I" + fbr).Value = "1"
- ws.Range("J" + fbr).Value = "4"
- ws.Range("O" + fbr).Value = """Książki" + vbCrLf + "------" + vbCrLf + "www.podsowa.pl"""
- End Function
- Function firstBlankRow(ws As Worksheet) As Long
- 'returns the row # of the row after the last used row
- 'Or the first row with no data in it
- Dim rw As Range
- For Each rw In ws.UsedRange.Rows
- If rw.Address = ws.Range(rw.Address).SpecialCells(xlCellTypeBlanks). _
- Address Then
- firstBlankRow = rw.Row
- Exit For
- End If
- Next
- If firstBlankRow = 0 Then
- firstBlankRow = ws.Cells.SpecialCells(xlCellTypeLastCell). _
- Offset(1, 0).Row - 3
- End If
- End Function
- Function MYMATCH(strValue As String, strPattern As String, Optional blnCase As Boolean = True, Optional blnBoolean = True) As String
- Dim objRegEx As Object
- Dim strPosition As Integer
- Dim RegMC
- ' Create regular expression.
- Set objRegEx = CreateObject("VBScript.RegExp")
- With objRegEx
- .Pattern = strPattern
- .IgnoreCase = blnCase
- If .test(strValue) Then
- Set RegMC = .Execute(strValue)
- MYMATCH = RegMC(0).firstindex + 1
- Else
- MYMATCH = 0
- End If
- End With
- End Function
- Function LoadFromFile(filePath As String) As String
- Open filePath For Input As #1
- Dim Total As String
- While EOF(1) = False
- Line Input #1, strLine
- Total = Total & vbNewLine & strLine
- i = i + 1
- Wend
- LoadFromFile = Total
- Close #1
- End Function
- Function CheckCountry(country As String) As Integer
- Dim countries() As String
- 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")
- End Function
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement