Word – Splitting by Heading to Txt Files (All Headings)

Function Ping(strip)
Dim objshell, boolcode
Set objshell = CreateObject("Wscript.Shell")
boolcode = objshell.Run("ping -n 1 -w 1000 " & strip, 0, True)
If boolcode = 0 Then
    Ping = True
Else
    Ping = False
End If
End Function
Sub PingSystem()
Dim strip As String
Dim strPhoneNumber As String
Dim strMessage As String
Dim strPostData As String
Dim IE As Object

strPhoneNumber = Sheets("DATA").Cells(2, 1).Value

For introw = 2 To ActiveSheet.Cells(65536, 2).End(xlUp).Row
    strip = ActiveSheet.Cells(introw, 2).Value
    If Ping(strip) = True Then
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 0, 0)
        ActiveSheet.Cells(introw, 3).Value = "Online"
        Application.Wait (Now + TimeValue("0:00:01"))
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 200, 0)
        
'Send Whatsapp Message
        strMessage = "Ping " & ActiveSheet.Cells(introw, 1).Value & " " & ActiveSheet.Cells(introw, 2).Value & " is Online"
        
'IE.navigate "whatsapp://send?phone=phone_number&text=your_message"
        strPostData = "whatsapp://send?phone=" & strPhoneNumber & "&text=" & strMessage
        Set IE = CreateObject("InternetExplorer.Application")
        IE.navigate strPostData
        Application.Wait Now() + TimeSerial(0, 0, 3)
        SendKeys "~"

        Set IE = Nothing
        
    Else
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
        ActiveSheet.Cells(introw, 3).Font.Color = RGB(200, 0, 0)
        ActiveSheet.Cells(introw, 3).Value = "Offline"
        Application.Wait (Now + TimeValue("0:00:01"))
        ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 6
        
'Send Whatsapp Message
        strMessage = "Ping " & ActiveSheet.Cells(introw, 1).Value & " " & ActiveSheet.Cells(introw, 2).Value & " is Offline"
        
'IE.navigate "whatsapp://send?phone=phone_number&text=your_message"
        strPostData = "whatsapp://send?phone=" & strPhoneNumber & "&text=" & strMessage
        Set IE = CreateObject("InternetExplorer.Application")
        IE.navigate strPostData
        Application.Wait Now() + TimeSerial(0, 0, 3)
        SendKeys "~"
        Set IE = Nothing
    End If
Next
End Sub

Private Sub OpeFile_MutipleFile()

'VARIABLE'

Dim A As Variant
Dim AA As Variant

Dim B As Workbook
Dim C As Worksheet
Dim D As String

On Error Resume Next

'FUNCTION AS'
A = Application.GetOpenFilename(MultiSelect:=True, Password:=ABC)
D = ThisWorkbook.Worksheets("X").Range("A1").Value

'SET VARIABLE'
Set C = ThisWorkbook.Worksheets("Y")

For Each AA In A
	
	'OPEN FILE
	 Set B = Application.Workbooks.Open(AA)

    'CREATE CONDITIONS
    If C.Range("A2") = "" Then
  
		'TYPE PROCESS - 1 HERE'
		C.Range("B1").AutoFilter Field:=1, Criteria1:="TYPE1"
		C.Range("B1").CurrentRegion.Copy

		C.Range("B2").PasteSpecial xlPasteValues
		B.Close SaveChanges:=False
    
    'NEXT CONDTION CONDITIONS'
    Else

		'TYPE PROCESS - 2 HERE'
		C.Range("B1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 10).Select
		Range(Selection, Cells(1, 1)).Select
		Selection.Copy

		C.Range("B1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
		B.Close SaveChanges:=False

    End If
    
 On Error GoTo 0
    
Next

End Sub

Declare @MinValueWanted int = 500,
  @MaxValueWanted int = 3000;
Select abs(cast(newid() as binary(6)) % (1 + 9006 - 9001)) + 9001;

USE OLIS_DATA_DEMO;

/************/
--24_StaffNumberOfPersonInjured
UPDATE [dbo].[AIRSData]
SET [24_StaffNumberOfPersonInjured] = abs(cast(newid() as binary(6)) % (1 + 9006 - 9001)) + 9001
WHERE [24_StaffNumberOfPersonInjured] =9004 
AND [AIRSID] > 54812

vba - Copy headings and Contents to new document - Stack Overflow 


Sub SplitDocumentByHeading() 

Application.ScreenUpdating = False 

Dim DocSrc As Document, DocTgt As Document, Rng As Range, i As Long 

Dim StrTmplt As String, StrNm As String, StrEx As String, lFmt As Long 

Set DocSrc = ActiveDocument 

With DocSrc 

  StrTmplt = .AttachedTemplate.FullName 

  StrNm = Split(.FullName, ".doc")(0) 

  StrEx = Split(.FullName, ".doc")(1) 

  lFmt = .SaveFormat 

  With .Range 

    With .Find 

      .ClearFormatting 

      .Replacement.ClearFormatting 

      .Text = "" 

      .Style = wdStyleHeading1 

      .Replacement.Text = "" 

      .Forward = True 

      .Wrap = wdFindStop 

      .Format = True 

      .MatchCase = False 

      .MatchWholeWord = False 

      .MatchWildcards = False 

      .MatchSoundsLike = False 

      .MatchAllWordForms = False 

      .Execute 

    End With 

    Do While .Find.Found 

      i = i + 1 

      Set Rng = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel") 

      Set DocTgt = Documents.Add(Template:=StrTmplt, Visible:=False) 

      With DocTgt 

        .Range.FormattedText = Rng.FormattedText 

        .SaveAs2 FileName:=StrNm & "_" & Format(i, "00") & ".txt", Fileformat:=wdFormatText, AddToRecentFiles:=False 'this sets the format 

        .Close 

      End With 

      .Collapse wdCollapseEnd 

      .Find.Execute 

    Loop 

  End With 

End With 

Set DocTgt = Nothing: Set Rng = Nothing: Set DocSrc = Nothing 

Application.ScreenUpdating = True 

End Sub 

Sub SaveSelectedTextToNewDocument()
    If Selection.Words.Count > 0 Then
    'Copy the selected text
    Selection.Copy            

    'Open a new document and paste the copied text into it
    Dim objNewDoc As Document
    Set objNewDoc = Documents.Add
    Selection.Paste

    'Get the first 10 characters as the filename of the new document and save them
    Dim objFileName As Range
    Set objFileName = objNewDoc.Range(Start:=0, End:=10)
    objNewDoc.SaveAs FileName:="C:\Users\Test\Desktop\" & objFileName & ".docx"
    Else

    End If
End Sub

Private Sub from_upper()
'SELECT CELL AFTER FILTER AND VISIBLE ONLY FROM UPPER WITHOUT TILE'

Dim ws As Worksheet
   
Set ws = Worksheets("Gen.Report")
ws.Activate
ws.Range("A1").Offset(1, 0).Select
Range(Selection, Selection.End(xlToRight)).Select
    
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select
Loop
Range(Selection, Selection.End(xlToRight).End(xlDown)).Select


End Sub


'=============================================================================='


Private Sub from_below()
'SELECT CELL AFTER FILTER AND VISIBLE ONLY FROM BELOW WITH TILE'

Dim ws As Worksheet
   
Set ws = Worksheets("Gen.Report")
ws.Activate
ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Select
    
Do Until ActiveCell.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select
Loop
Range(Selection, Selection.End(xlToRight).End(xlUp)).Select


End Sub

' Put this code in your form's before_update

Private Sub Form_BeforeUpdate(Cancel As Integer)
Call AuditTrail(Me, [SUArchiveID])
End Sub



' Put code below in your Audit Module
Enum AuditAction
    Add
    Delete
    Edit
    Bulk
    DbgError
End Enum

Function getAuditEnumString(eValue As AuditAction) As String
    Select Case eValue
        Case Add
            getAuditEnumString = "ADD"
        Case Edit
            getAuditEnumString = "EDIT"
        Case Delete
            getAuditEnumString = "DELETE"
        Case DbgError
            getAuditEnumString = "ERROR"
    End Select
End Function





Public Sub AuditTrail(frm As Form, CourseID As String, recordID As String, Optional action As AuditAction)

  'Track changes to data.
  'recordid identifies the pk field's corresponding
  'control in frm, in order to id record.
  Dim ctl As Control
  Dim varBefore As Variant
  Dim varAfter As Variant
  Dim strControlName As String
  Dim strSQL As String
  Dim auditActionStr As String
  
  On Error GoTo ErrHandler
  
  
  
  If IsMissing(action) Then
    auditActionStr = getAuditEnumString(AuditAction.Edit)
    Else
        auditActionStr = getAuditEnumString(action)
  End If
  
  Dim sqlCollection As New Collection
  'On Error GoTo ErrHandler
  'Get changed values.
  For Each ctl In frm.Controls
    With ctl
    'Avoid labels and other controls with Value property.
    Select Case .ControlType
        Case acComboBox, acListBox, acTextBox
        If IsOldValueAvailable(ctl) Then
            If .value <> .oldValue Then
              varBefore = .oldValue
              varAfter = .value
              strControlName = .Name
              'Build INSERT INTO statement.
              strSQL = "INSERT INTO " _
                 & "Audit (EditDate, User, RecordID, SourceTable, " _
                 & " SourceField, BeforeValue, AfterValue, FormName, CourseID, Action) " _
                 & "VALUES (Now()," _
                 & cDQ & getLoggedInUserID & cDQ & ", " _
                 & cDQ & recordID & cDQ & ", " _
                 & cDQ & Replace(Left(frm.RecordSource, 255), Chr(34), "") & cDQ & ", " _
                 & cDQ & .Name & cDQ & ", " _
                 & cDQ & varBefore & cDQ & ", " _
                 & cDQ & varAfter & cDQ & ", " _
                  & cDQ & Left(frm.Name, 255) & cDQ & ", " _
                  & cDQ & CourseID & cDQ & ", " _
                  & cDQ & auditActionStr & cDQ & ")"
              
              'sqlCollection.Add strSQL
              CurrentDb.Execute strSQL
              'MsgBox "Audit " + strSQL
            End If
        End If
    End Select

    End With
  Next
  Set ctl = Nothing
  'Set AuditTrail = sqlCollection
  Exit Sub

ErrHandler:
  MsgBox "Audit Trail Error:" & Err.Description & vbNewLine _
   & Err.number, vbOKOnly, "Error"
End Sub

' SQL Code below to create Audit table
CREATE TABLE [dbo].[Audit](
	[EditedRecordID] [int] IDENTITY(1,1) NOT NULL,
	[EditDate] [datetime] NULL,
	[User] [nvarchar](255) NULL,
	[RecordID] [nvarchar](255) NULL,
	[SourceTable] [nvarchar](255) NULL,
	[SourceField] [nvarchar](255) NULL,
	[BeforeValue] [nvarchar](255) NULL,
	[AfterValue] [nvarchar](255) NULL,
	[FormName] [nvarchar](255) NULL,
	[CourseID] [nvarchar](255) NULL,
	[Action] [nvarchar](10) NULL,
 CONSTRAINT [Audit$PrimaryKey] PRIMARY KEY CLUSTERED 
(
	[EditedRecordID] ASC
)WITH (PAD_INDEX = OFF, STATISTICS_NORECOMPUTE = OFF, IGNORE_DUP_KEY = OFF, ALLOW_ROW_LOCKS = ON, ALLOW_PAGE_LOCKS = ON) ON [PRIMARY]
) ON [PRIMARY]

                Me!AdminStaffID = myLog!AdminStaffID
                If myLog!AdminStaffID = vbNullString Then
                    Me!AdminEmailAddress = ""
                    Me!AdminTelephone = ""
                Else
                    Me!AdminEmailAddress = DLookup("[WorkEmailAddress]", "tbl_Import_StaffListAll", "[StaffID] = [Forms]![ServiceProviderStructure - Sectors_Add_Edit]![AdminStaffID]")
                    Me!AdminTelephone = DLookup("[WorkMobileNumber]", "tbl_Import_StaffListAll", "[StaffID] = [Forms]![ServiceProviderStructure - Sectors_Add_Edit]![AdminStaffID]")
                End If

// https://www.thesmallman.com/looping-through-worksheets

Sub MovethroughWB1() 
'Excel VBA looping procedure, loop excludes first tab on the left'

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets 'Start the VBA Loop.
If ws.Index <> 1 Then 'Exclude the first sheet on the left from the procedure.n 'Perform the Action you wish.
ws.Range("B10:B20").Interior.Color=vbCyan
End If
Next ws
End Sub

// https://www.automateexcel.com/vba/sheets-worksheets
//  Guide Worksheet update by pp_92

'Tab Name'
Sheets("Input").Activate

'VBA Code Name'
Sheet1.Activate

'Index Position'
Sheets(1).Activate
	
'Select Sheet'
Sheets("Input").Select

'Set to Variable'
Dim ws as Worksheet
Set ws = ActiveSheet

'Name / Rename'
ActiveSheet.Name = "NewName"

'Rename as In Cell'
Worksheets(1).Name = Worksheets(1).Range("B5")

'Insert Name Worksheet in Cell'
ActiveSheet.Range("A1") = ActiveSheet.Name

'Rename as In Cell Loop'
Dim rs As Worksheet
For Each rs In Sheets
rs.Name = rs.Range("B5")
Next rs

'Next Sheet'
ActiveSheet.Next.Activate

'Loop Through all Sheets'
Dim ws as Worksheet
For each ws in Worksheets
Msgbox ws.name
Next ws

'Loop Through Selected Sheets'
Dim ws As Worksheet
For Each ws In ActiveWindow.SelectedSheets
MsgBox ws.Name
Next ws

'Get ActiveSheet'
MsgBox ActiveSheet.Name

'Add Sheet'
Sheets.Add

'Add Sheet and Name'
Sheets.Add.Name = "NewSheet"

'Add Sheet With Name From Cell'
Sheets.Add.Name = range("a3").value

'Add Sheet After Another'
Sheets.Add After:=Sheets("Input")

'Add Sheet After and Name'
Sheets.Add(After:=Sheets("Input")).Name = "NewSheet"

'Add Sheet Before and Name'
Sheets.Add(Before:=Sheets("Input")).Name = "NewSheet"

'Add Sheet to End of Workbook'
Sheets.Add After:=Sheets(Sheets.Count)

'Add Sheet to Beginning of Workbook'
Sheets.Add(Before:=Sheets(1)).Name = "FirstSheet"

'Add Sheet to Variable'
Dim ws As Worksheet
Set ws = Sheets.Add

'Move Sheet to End of Workbook'
Sheets("Sheet1").Move After:=Sheets(Sheets.Count)

'To New Workbook'
Sheets("Sheet1").Copy

'Selected Sheets To New Workbook'
ActiveWindow.SelectedSheets.Copy

'Before Another Sheet'
Sheets("Sheet1").Copy Before:=Sheets("Sheet2")

'Before First Sheet'
Sheets("Sheet1").Copy Before:=Sheets(1)

'After Last Sheet'
Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)

'Copy and Name'
Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "LastSheet"

'Copy and Name From Cell Value'
Sheets("Sheet1").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Range("A1").Value

'To Another Workbook'
Sheets("Sheet1").Copy Before:=Workbooks("Example.xlsm").Sheets(1)
	
'Hide Sheet'
Sheets("Sheet1").visible = False
or 
Sheets("Sheet1").visible = xlSheetHidden

'Unhide Sheet'
Sheets("Sheet1").Visible = True
or
Sheets("Sheet1").Visible = xlSheetVisible

'Very Hide Sheet'
Sheets("Sheet1").Visible = xlSheetVeryHidden

'Delete Sheet'
Sheets("Sheet1").Delete

'Delete Sheet (Error Handling)'
On Error Resume Next
Sheets("Sheet1").Delete
On Error GoTo 0

'Delete Sheet (No Prompt)'
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True

'Clear Sheet'
Sheets("Sheet1").Cells.Clear

'Clear Sheet Contents Only'
Sheets("Sheet1").Cells.ClearContents

'Clear Sheet UsedRange'
Sheets("Sheet1").UsedRange.Clear

'Unprotect (No Password)'
Sheets("Sheet1").Unprotect

'Unprotect (Password)'
Sheets("Sheet1").Unprotect "Password"

'Protect (No Password)'
Sheets("Sheet1").Protect

'Protect (Password)'
Sheets("Sheet1").Protect "Password"

'Protect but Allow VBA Access'
Sheets("Sheet1").Protect UserInterfaceOnly:=True

'Unprotect All Sheets'
Dim ws As Worksheet
For Each ws In Worksheets
ws.Unprotect "password"
Next ws

Private Sub MoveSheetRight()
'MOVE WORKSHEET TO RIGHT'

Dim s As Worksheet
Set s = ActiveSheet

If s.Next Is Nothing Then Exit Sub
s.Move after:=s.Next

End Sub



Private Sub MoveSheetLeft()
'MOVE WORKSHEET TO LEFT'

Dim s As Worksheet
Set s = ActiveSheet

If s.Previous Is Nothing Then Exit Sub
s.Move before:=s.Previous

End Sub



Private Sub ActiveSheetbyCount()
'GO TO ACTIVE WORKSHEET TO RIGHT STEP TO STEP'

If ActiveSheet.Index < ThisWorkbook.Sheets.Count Then
Sheets(ActiveSheet.Index + 1).Activate
    Else
    Sheets(1).Activate
End If

End Sub



Private Sub GoTolastSheet()
'GO TO ACTIVE WORKSHEET TO LAST SHEET - RIGHT'

On Error Resume Next
Sheets(Sheets.Count).Select

End Sub



Private Sub GoToFirstSheet()
'GO TO ACTIVE WORKSHEET TO LAST SHEET - LEFT'

On Error Resume Next
Sheets(1).Select

End Sub

Sub create_sheet_from_list()

Dim MyCell As Range, MyRange As Range

Set MyRange = Sheets("Generate").Range("C6")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.EnableEvents = False

    For Each MyCell In MyRange
        If MyCell.Value = "" Then 'Check for null/empty value cell'
            Exit Sub 'If reach to null cell then exit sub'
        Else
            Sheets("X").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet'
            Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet'
        End If
    Next MyCell
    
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.EnableEvents = True

End Sub

Sub newB()
    Dim rgnFilter As Range, rgnArea As Range, rgnRow As Range
    Dim i As Long, lastRow As Long
    Dim toDelete As Boolean

    With Sheet1
        'If data is unfiltered then exit sub'
        If .AutoFilterMode = False Then
            MsgBox "Please filter the data first.", vbInformation
            Exit Sub
        End If
        
        'Get lastRow data'
        lastRow = .Range("C" & Rows.Count).End(xlUp).Row
        
        'Set column C filtered data as rgn'
        Set rgnFilter = .Range("C7:C" & lastRow).SpecialCells(xlCellTypeVisible)
        
        toDelete = False
        
        'loop each filtered area'
        For Each rgnArea In rgnFilter.Areas
        
            'If filtered area have rows>1 then proceed'
            If rgnArea.Rows.Count > 1 Then
            
                'Loop each cell in each filtered area'
                For Each rgnRow In rgnArea
                
                    'If toDelete = false then skip else delete in cell B row'
                    If toDelete = False Then
                        toDelete = True
                    Else
                        .Range("B" & rgnRow.Row).Value = Empty
                        toDelete = False
                    End If
                Next rgnRow
            End If
        Next rgnArea
        
        'Unfilter sheet'
        .AutoFilterMode = False
    End With
    
End Sub

Private Sub Excel3rd_as_Generator()

Dim A As String
Dim B1 As Workbook, B2 As Workbook
Dim C As String

'PATH REPORT TO PASTE'
'A = "C:\Users\phareh\Desktop\x.xlsm"'
A = ThisWorkbook.Worksheets("SRM_BAL_R2018_AR").Range("H4").Value
'PATH DATA REPORT TO COPY'
'A = "C:\Users\phareh\Download\y.xlsm"'
C = ThisWorkbook.Worksheets("SRM_BAL_R2018_AR").Range("E4").Value

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.EnableEvents = False

On Error Resume Next

Set B1 = Application.Workbooks.Open(A)

'IF DATA EMPTY THEN PASTE'
If B1.Sheets(1).Range("A2") = "" Then
Set B2 = Application.Workbooks.Open(C)
B.Activate
Rows("6:6").Select

'CREATE FILTER'
Selection.AutoFilter
ActiveSheet.Range("A6:O6").AutoFilter Field:=5, Criteria1:="SRM"
B.Sheets(1).Range("A6:O6").Select
Range(Selection, Selection.End(xlDown)).Copy
B1.Sheets("R2018 (AR)").Range("A1").PasteSpecial
B2.Close False
B1.Close SaveChanges:=True
    
	'IF DATA EXIST THEN PASTE'
    Else
    Set B2 = Application.Workbooks.Open(C)
    B.Activate
    Rows("6:6").Select
	
	'CREATE FILTER'
    Selection.AutoFilter
    ActiveSheet.Range("A6:O6").AutoFilter Field:=5, Criteria1:="SRM"
    B.Sheets(1).Range("A6:O6").Select
    Range(Selection, Selection.End(xlDown)).Copy
    B1.Sheets("R2018 (AR)").Activate
    Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
    B2.Close False
    B1.Close SaveChanges:=True
                
End If

On Error GoTo 0

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.EnableEvents = True

End Sub

// .vbs file
Dim args, objExcel

set args = wscript.Arguments
set objExcel = createobject("Excel.Application")

objExcel.workbooks.open args(0) 
objExcel.visible = True

objExcel.Run "Module1.Macro1"
objExcel.Activeworkbook.Save 
objExcel.Activeworkbook.Close(0)
objExcel.Quit



// .bat file
cscript "C:\Users\phareh_92(2)\Documents\X.vbs" "C:\Users\phareh_92(2)\Documents\Y.xlsm"