Skip to main content

скрипт генерации пост из домена

Sub generateemails()

Dim countdelimiter As Integer
Dim j, i, k, iCellColEmail As Integer
Dim sCell, sCellEmailText As String
Dim TestArray() As String
Dim ithisrow, imaxrows As Long

  
    Columns("A:A").Select
    
    'âñòàâèì äëÿ íà÷àëà ñòîëáåö ïî êîòîðîìó áóäåì åìàéëû âñòàâëÿòü
    Range("A1").Activate
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "email1"
    
    imaxrows = 100000
    iCellColEmail = 4
    
    For ithisrow = 2 To imaxrows
    
            ' Cells(ñòðîêà, ñòîëáåö) çàáåðåì äîìåí
            sCellDomenText = Cells(ithisrow, iCellColEmail).Value
            
            'åñëè äîìåí åñòü è ìû íå äîáðàëèñü äî êîíöà ñïèñêà òî äåëàåì
          If Len(sCellDomenText) > 0 Then
            
            sCellEmailText = "info|mail|office|sales|zakaz|sale|pr|marketing|shop|buh|hello|service|hr|contact|manager|director|dir|tender|reception|it|zakupki|feedback|clients|priemnaya|adm|admin|ceo|tech|main|direktor|secretar|sekretar|manager1|manager2|manager3|registratura|info1|info2|info3"
            
            'ïîëó÷èì ìàññèâ åìàéëîâ ÷òîáû âñòàâëÿòü â ïåðâûé ñòîëáåö òî ÷òî ïåðåä @
            TestArray = Split(sCellEmailText, "|")
            
            
            For k = LBound(TestArray) To UBound(TestArray)
                If Len(TestArray(k)) > 0 Then
                                        
                                       
                    If k > 0 Then
                    'ñêîïèðóåì åå â áóôåð îáìåíà íà÷àëüíóþ ñòðîêó
                    Rows(ithisrow).Select
                    Selection.Copy
                    
                    Selection.Insert Shift:=xlDown
                    Application.CutCopyMode = False
                    
                    ithisrow = ithisrow + 1
                        
                    End If
                    
                    
                    Cells(ithisrow, 1).Value = TestArray(k) & "@" & sCellDomenText
                                       
                    
                    'îáùåå êîëè÷åñòâî ñòðîê áóäåò óâåëè÷èâàòüñÿ
                    
                End If
            Next
         End If
    Next
    
End Sub