Sub RemoveDuplicatesAndKeepLatest()
    Dim ws As Worksheet
    Set ws = [thisworkbook](/activeworkbook-thisworkbook/).Sheets("YourSheetName") ' Assign [Worksheet](/vba/sheets-worksheets) object to "ws". Replace "YourSheetName" with the actual sheet name

    ' Assuming Column D contains the timestamp
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row  ' Find the last row in the worksheet

    ' Perform sort operation based on columns 1,3 and timestamp in Column D (adjust accordingly)
    With ws.Sort
        .SortFields.Clear  
        .SortFields.Add Key:=ws.Range("A2:A" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal   ' Sort on column A ascendingly
        .SortFields.Add Key:=ws.Range("C2:C" & lastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal   ' Sort on column C ascendingly
        .SortFields.Add Key:=ws.Range("D2:D" & lastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal  ' Sort on column D descendingly (to keep the latest)
        .SetRange ws.Range("A1:AD" & lastRow) 
        .Header = xlYes  
        .MatchCase = False  
        .Orientation = xlTopToBottom  
        .SortMethod = xlPinYin  
        .Apply  ' Apply the sorting to the range
    End With

    ' Loop through the sorted range and remove duplicates, keeping the latest occurrence
    Dim currentRow As Long
    For currentRow = lastRow To 3 Step -1 ' Loop from the bottom of sheet to the top
        If ws.Cells(currentRow, 1).Value = ws.Cells(currentRow - 1, 1).Value And _
           ws.Cells(currentRow, 3).Value = ws.Cells(currentRow - 1, 3).Value Then
            ' If corresponding cells in Column A and Column C are identical, delete the current row
            ws.Rows(currentRow).Delete  ' Delete the row
        End If
    Next currentRow
End Sub

SELECT

  LEFT(CONVERT(varchar,[REQ ITEM CHECKIN DATETIME], 120),16) as วันที่รับแล็บ
     ,LEFT(CONVERT(varchar,[ORDER DATETIME], 120),16) as วันที่สั่ง
     ,[HN]
     ,[LN]
     ,[FULLNAME] as [ชื่อ-สกุล]
     ,[YEAR] as ปี
     ,[SEX] as เพศ
     ,[WARD NAME] as จุดที่สั่ง
     ,[REQ ITEM GROUP CODE] as CODE
     ,[RES ITEM NAME] as รายการตรวจ
     ,[RES ITEM RESULT] as ผลการตรวจ
     ,[RES ITEM STATE] as state
     ,[ORDER COMMENT] as comment



  FROM [LAB_DB].[dbo].[view_lab_statistic_Result_List]

WHERE 
  [ORDER INACTIVE] ='n' 
     AND ([REQ ITEM GROUP CODE] ='SP' or [REQ ITEM GROUP CODE] ='PA')
     AND ([REQ STATE] ='a' or [REQ STATE] ='u')
	 
	 
	 --[REQ ITEM CHECKIN DATETIME]
	 --Checkin

CASE WHEN "%CH201%" = "<10" AND "%CH202%" = "<10" THEN "<30"
     WHEN "%CH201%" = "<10" AND "%CH202%" <> "" THEN "<30" 
	 WHEN "%CH201%" = "10" AND "%CH202%" = "<10" THEN "50"    
     WHEN "%CH201%" = "10" AND "%CH202%" = "10" THEN "100" 
	 WHEN "%CH201%" = "10" AND "%CH202%" = "50" THEN "20" 
	 WHEN "%CH201%" = "10" AND "%CH202%" = "100" THEN "10" 
	 WHEN "%CH201%" = "10" AND "%CH202%" = "200" THEN "5" 
	 WHEN "%CH201%" = "10" AND "%CH202%" = "300" THEN "3" 
	 WHEN "%CH201%" = "10" AND "%CH202%" = ">300" THEN "<30" 
	 WHEN "%CH201%" = "30" AND "%CH202%" = "<10" THEN "150" 
	 WHEN "%CH201%" = "30" AND "%CH202%" = "10" THEN "300" 
	 WHEN "%CH201%" = "30" AND "%CH202%" = "50" THEN "60" 
	 WHEN "%CH201%" = "30" AND "%CH202%" = "100" THEN "30"
	 WHEN "%CH201%" = "30" AND "%CH202%" = "200" THEN "15"
	 WHEN "%CH201%" = "30" AND "%CH202%" = "300" THEN "10"
	 WHEN "%CH201%" = "30" AND "%CH202%" = ">300" THEN "<30"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "<10" THEN ">300"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "10" THEN ">300"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "50" THEN "160"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "100" THEN "80"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "200" THEN "40"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "300" THEN "27"
	 WHEN "%CH201%" = "80" AND "%CH202%" = "<30" THEN "<30"
	 WHEN "%CH201%" = "150" AND "%CH202%" = "<10" THEN ">300"
	 WHEN "%CH201%" = "150" AND "%CH202%" = "10" THEN ">300"
	 WHEN "%CH201%" = "150" AND "%CH202%" = "50" THEN "300"
	 WHEN "%CH201%" = "150" AND "%CH202%" = "100" THEN "150"
	 WHEN "%CH201%" = "150" AND "%CH202%" = "200" THEN "75"
	 WHEN "%CH201%" = "150" AND "%CH202%" = "300" THEN "50"
	 WHEN "%CH201%" = "150" AND "%CH202%" = ">300" THEN "<30"
	 WHEN "%CH201%" = ">150" AND "%CH202%" <> "" THEN ">300"
 ELSE "N/A" END

 [SOURCE CODE]

[WARD]

[PRIORITY]

[PATIENT TYPE CODE]

[YEAR]

[SEX]

[REQ ITEM ORDER DATETIME]

declare @value decimal(10,2)
set @value = (select 
CASE WHEN %CH003% = 0 THEN 0 
WHEN {AGE,YEAR} > 130.0 THEN 0 
WHEN {AGE,YEAR} < 18.0 THEN ((0.41 * {HEIGHT}) / %CH003%) 
WHEN {SEX} = "M" AND %CH003% <= 0.9 THEN ((141 * (POWER((%CH003% / 0.9), -0.411))) * POWER(0.993, {AGE,YEAR})) 
WHEN {SEX} = "M" AND %CH003% > 0.9 THEN ((141 * (POWER((%CH003% / 0.9), -1.209))) * POWER(0.993, {AGE,YEAR})) 
WHEN {SEX} = "F" AND %CH003% <= 0.7 THEN ((144 * (POWER((%CH003% / 0.7), -0.329))) * POWER(0.993, {AGE,YEAR})) 
WHEN {SEX} = "F" AND %CH003% > 0.7 THEN ((144 * (POWER((%CH003% / 0.7), -1.209))) * POWER(0.993, {AGE,YEAR})) ELSE 0 END)

SELECT CASE WHEN @value > 90.0 THEN "Stage G1"      
WHEN @value >= 60.00 AND @value <= 89.99 THEN "Stage G2"      
WHEN @value >= 45.00 AND @value <= 59.99 THEN "Stage G3a"      
WHEN @value >= 30.00 AND @value <= 44.99 THEN "Stage G3b"      
WHEN @value >= 15.00 AND @value <= 29.99 THEN "Stage G4"      
WHEN @value <  15.00 THEN "Stage G5"      
ELSE "N/A" END

taskkill /F /IM  I-CN-HIS.exe /T


D:

cd  D:\LisInterface\HIS\i-CN-HIS XML

start i-CN-HIS.exe

//เด็กคอม www.dek-com.com

const ACCESS_TOKEN = "ACCESS_TOKEN";

const bot = new LineBotSdk.client(ACCESS_TOKEN);

function doPost(e) { bot.call(e, callback) };

function callback(e) {

  if (e.message.type == "text" ) {

     bot.replyMessage(e, [bot.textMessage(bard(e.message.text, 'en', 'th'))]);

  }

};

//เด็กคอม www.dek-com.com

function bard(prompt) {

  var promptEN = LanguageApp.translate(prompt, 'th', 'en'); // เพิ่มจุดที่ 1

  var api_key = "API KEY"; //bard2 api

  var url = "https://generativelanguage.googleapis.com/v1beta2/models/text-bison-001:generateText?key=" + api_key;

  var headers = {

    "Content-Type": "application/json"

  };

  var requestBody = {

    "prompt": {

    "text": promptEN

    }

  }

  

  var options = {

    "method" : "POST",

    "headers": headers,

    "payload": JSON.stringify(requestBody)

  }

  var response = UrlFetchApp.fetch(url,options);

  var data = JSON.parse(response.getContentText());

  var output = data.candidates[0].output;

  return  LanguageApp.translate(output, 'en', 'th'); // เพิ่มจุดที่ 2

}

//เด็กคอม www.dek-com.comDepoy ใหม่ด้วยนะครับ 😊

//เด็กคอม www.dek-com.com

const ACCESS_TOKEN = "ACCESS_TOKEN";

const bot = new LineBotSdk.client(ACCESS_TOKEN);

function doPost(e) { bot.call(e, callback) };

function callback(e) {

  if (e.message.type == "text" ) {

     bot.replyMessage(e, [bot.textMessage(bard(e.message.text, 'en', 'th'))]);

  }

};

//เด็กคอม www.dek-com.com

function bard(prompt) {

  var promptEN = LanguageApp.translate(prompt, 'th', 'en'); // เพิ่มจุดที่ 1

  var api_key = "API KEY"; //bard2 api

  var url = "https://generativelanguage.googleapis.com/v1beta2/models/text-bison-001:generateText?key=" + api_key;

  var headers = {

    "Content-Type": "application/json"

  };

  var requestBody = {

    "prompt": {

    "text": promptEN

    }

  }

  

  var options = {

    "method" : "POST",

    "headers": headers,

    "payload": JSON.stringify(requestBody)

  }

  var response = UrlFetchApp.fetch(url,options);

  var data = JSON.parse(response.getContentText());

  var output = data.candidates[0].output;

  return  LanguageApp.translate(output, 'en', 'th'); // เพิ่มจุดที่ 2

}

//เด็กคอม www.dek-com.com

Sub invoiceConcat()

''工作表名稱
Const kWSName As String = "工作表2"
''使用範圍列數
Dim kRow As Integer
''外層For迴圈計數器
Dim kCNT As Integer
''內層For迴圈計數器
Dim kCounter As Integer
''用來當作索引的發票號碼
Dim kTarget As String
''發票明細
Dim kDetail As String

ThisWorkbook.Worksheets(kWSName).Select

With ActiveSheet
''取得最後一列列號
    kRow = .Range("A65536").End(xlUp).Row
    
    For kCNT = 3 To kRow
    ''發票號碼
        kTarget = .Cells(kCNT, 7)
        
        For kCounter = 1 To kRow
            If .Cells(kCounter, 2) = kTarget Then
                ''可自己設定所需的明細格式
                kDetail = kDetail & Trim(.Cells(kCounter, 4)) & " [NT$ " & .Cells(kCounter, 3) & "]" & Chr(13)
            End If
        Next kCounter
        
        ''刪除句尾多的一個換行符號
        If kDetail <> "" Then
            .Cells(kCNT, 10) = Mid(kDetail, 1, Len(kDetail) - 1)
        End If
        ''明細字串重置
        kDetail = ""
    Next kCNT
End With

End Sub

UPDATE dbo.tbl_lab_setup_Source_Definition
SET Source_Definition_Name = CASE

			WHEN Source_Definition_Code = '000'	  THEN		'ไม่ทราบฝ่าย'
			WHEN Source_Definition_Code = '001'   THEN      'ความดัน'
			WHEN Source_Definition_Code = '002'   THEN      'เบาหวาน'
			WHEN Source_Definition_Code = '003'   THEN      'โรคปอด'
			WHEN Source_Definition_Code = '004'   THEN      'จุดซักประวัติ VIP'
			WHEN Source_Definition_Code = '005'   THEN      'ฝ่ายทันตสาธารณสุข'
			WHEN Source_Definition_Code = '006'   THEN      'หน้าห้องฉุกเฉิน'
			WHEN Source_Definition_Code = '007'   THEN      'ห้อง LAB'
			WHEN Source_Definition_Code = '008'   THEN      'ฝ่าย Computer'
			WHEN Source_Definition_Code = '009'   THEN      'ตึกผู้ป่วยใน'
			WHEN Source_Definition_Code = '010'   THEN      'จุดซักประวัติOPD1'
			WHEN Source_Definition_Code = '011'   THEN      'ห้อง Emergency Room (ER)'
			WHEN Source_Definition_Code = '012'   THEN      'ฝ่าย X-Ray'
			WHEN Source_Definition_Code = '013'   THEN      'ฝ่ายเวชระเบียน'
			WHEN Source_Definition_Code = '014'   THEN      'ห้องตรวจโรค'
			WHEN Source_Definition_Code = '015'   THEN      'CUPS'
			WHEN Source_Definition_Code = '016'   THEN      'ห้องจ่ายเงินผู้ป่วยนอก'
			WHEN Source_Definition_Code = '017'   THEN      'ห้องคลอด'
			WHEN Source_Definition_Code = '018'   THEN      'ห้องจ่ายกลาง'
			WHEN Source_Definition_Code = '019'   THEN      'ห้องตรวจโรค1'
			WHEN Source_Definition_Code = '020'   THEN      'ห้องตรวจโรค2'
			WHEN Source_Definition_Code = '021'   THEN      'ห้องตรวจโรค 3'
			WHEN Source_Definition_Code = '022'   THEN      'ห้องงานสุขศึกษาประชาสัมพันธ์'
			WHEN Source_Definition_Code = '023'   THEN      'จุดชักประวัติ ARV'
			WHEN Source_Definition_Code = '024'   THEN      'โรงครัว'
			WHEN Source_Definition_Code = '025'   THEN      'ห้องทำหัตถการผู้ป่วยนอก'
			WHEN Source_Definition_Code = '026'   THEN      'จุดซักประวัติOPD2'
			WHEN Source_Definition_Code = '027'   THEN      'ห้องตรวจโรค 4'
			WHEN Source_Definition_Code = '028'   THEN      'ห้องตรวจโรค 5'
			WHEN Source_Definition_Code = '029'   THEN      'ห้องตรวจโรค 6'
			WHEN Source_Definition_Code = '030'   THEN      'ห้องจ่ายยาผู้ป่วยนอก'
			WHEN Source_Definition_Code = '031'   THEN      'จุดเรียกคิวสูตินารีเวช'
			WHEN Source_Definition_Code = '032'   THEN      'ห้องตรวจสูตินารีเวช'
			WHEN Source_Definition_Code = '033'   THEN      'ห้องตรวจโรคหัวใจ'
			WHEN Source_Definition_Code = '034'   THEN      'ห้องตรวจสุขภาพเด็กดี'
			WHEN Source_Definition_Code = '035'   THEN      'งานป้องกันโรค'
			WHEN Source_Definition_Code = '036'   THEN      'ห้องตรวจครรภ์'
			WHEN Source_Definition_Code = '037'   THEN      'ห้องตรวจจิตเวช'
			WHEN Source_Definition_Code = '038'   THEN      'NB (ทารกแรกเกิด)'
			WHEN Source_Definition_Code = '039'   THEN      'ห้องตรวจโรค7'
			WHEN Source_Definition_Code = '040'   THEN      'ห้องฉีดยา'
			WHEN Source_Definition_Code = '041'   THEN      'แพทย์แผนไทย'
			WHEN Source_Definition_Code = '042'   THEN      'กายภาพบำบัด'
			WHEN Source_Definition_Code = '043'   THEN      'Asthma'
			WHEN Source_Definition_Code = '044'   THEN      'ห้องตรวจโรค9'
			WHEN Source_Definition_Code = '045'   THEN      'ห้องตรวจโรค ARV'
			WHEN Source_Definition_Code = '046'   THEN      'HHC'
			WHEN Source_Definition_Code = '047'   THEN      'วัยทอง'
			WHEN Source_Definition_Code = '048'   THEN      'ฝ่ายส่งเสริมสุขภาพ'
			WHEN Source_Definition_Code = '049'   THEN      'ห้องตรวจโรค10'
			WHEN Source_Definition_Code = '050'   THEN      'จุดเรียกคิวคลีกนิคพิเศษ'
			WHEN Source_Definition_Code = '051'   THEN      'จุดเรียกคิว OPD'
			WHEN Source_Definition_Code = '052'   THEN      'Exit Nurse'
			WHEN Source_Definition_Code = '053'   THEN      'ห้องฟ้าใส'
			WHEN Source_Definition_Code = '054'   THEN      'ห้องผ่าตัด'
			WHEN Source_Definition_Code = '055'   THEN      'ห้องตรวจโรค8'
			WHEN Source_Definition_Code = '056'   THEN      'จุดซักประวัติตรวจสุขภาพประจำปี'
			WHEN Source_Definition_Code = '057'   THEN      'คลินิกผู้สูงอายุ'
			WHEN Source_Definition_Code = '058'   THEN      'ห้องจ่ายยาคลินิกพิเศษ'
			WHEN Source_Definition_Code = '059'   THEN      'ห้องตรวจธาลัสซีเมียในเด็ก'
			WHEN Source_Definition_Code = '060'   THEN      'คลิกนิคไข้หวัด'
			WHEN Source_Definition_Code = '061'   THEN      'Bloodbank'
			WHEN Source_Definition_Code = '062'   THEN      'จุดซักประวัติกุมารเวชกรรม'
			WHEN Source_Definition_Code = '063'   THEN      'จุดเรียกคิวกุมารเวชกรรม'
			WHEN Source_Definition_Code = '064'   THEN      'ห้องอัลตราชาวด์'
			WHEN Source_Definition_Code = '065'   THEN      'ห้องตรวจคลินิกพิเศษ1'
			WHEN Source_Definition_Code = '066'   THEN      'ห้องตรวจคลินิกพิเศษ2'
			WHEN Source_Definition_Code = '067'   THEN      'ห้องตรวจคลินิกพิเศษ3'
			WHEN Source_Definition_Code = '068'   THEN      'ห้องตรวจคลินิกพิเศษ4'
			WHEN Source_Definition_Code = '069'   THEN      'ห้องตรวจคลินิกพิเศษ5'
			WHEN Source_Definition_Code = '070'   THEN      'ห้องตรวจคลินิกพิเศษ6'
			WHEN Source_Definition_Code = '071'   THEN      'ห้องตรวจคลินิกพิเศษ7'
			WHEN Source_Definition_Code = '072'   THEN      'ห้องตรวจคลินิกพิเศษ8'
			WHEN Source_Definition_Code = '073'   THEN      'จุดเรียกคิวเบาหวาน+ความดัน'
			WHEN Source_Definition_Code = '074'   THEN      'จุดซักประวัติผู้ป่วยนอก2(ผู้ป่วยนัด)'
			WHEN Source_Definition_Code = '075'   THEN      'จุดซักประวัติผู้ป่วยนอก3(ผู้ป่วยมีไข้)'
			WHEN Source_Definition_Code = '076'   THEN      'คลินิกลดพุง'
			WHEN Source_Definition_Code = '077'   THEN      'จุดเรียกคิวผู้สูงอายุ'
			WHEN Source_Definition_Code = '078'   THEN      'Teen friendly'
			WHEN Source_Definition_Code = '079'   THEN      'ห้องตรวจส่งเสริม'
			WHEN Source_Definition_Code = '080'   THEN      'ตึกเด็ก'
			WHEN Source_Definition_Code = '081'   THEN      'ตึกชาย'
			WHEN Source_Definition_Code = '082'   THEN      'ตึกหญิง'
			WHEN Source_Definition_Code = '083'   THEN      'ตึกสูติ-นารีเวช'
			WHEN Source_Definition_Code = '084'   THEN      'ตึกศัลยกรรม'
			WHEN Source_Definition_Code = '085'   THEN      'จุดเรียกคิวศัลยกรรม'
			WHEN Source_Definition_Code = '086'   THEN      'จุดเรียกคิวศัลยกรรมเด็ก'
			WHEN Source_Definition_Code = '087'   THEN      '70 ปีไม่มีคิว'
			WHEN Source_Definition_Code = '088'   THEN      'ห้องวางแผนครอบครัว'
			WHEN Source_Definition_Code = '089'   THEN      'โรคเรื้อรัง'
			WHEN Source_Definition_Code = '090'   THEN      'ห้องตรวจผู้ป่วยCAPD'
			WHEN Source_Definition_Code = '091'   THEN      'ห้องตรวจผู้ป่วยHD'
			WHEN Source_Definition_Code = '092'   THEN      'จุดซักประวัติไตวายเรื้อรัง'
			WHEN Source_Definition_Code = '093'   THEN      'คลินิคพบแพทย์ส่งเสริม'
			WHEN Source_Definition_Code = '094'   THEN      'คลินิคWarfarin'
			WHEN Source_Definition_Code = '095'   THEN      'กลุ่มเสี่ยง-ทางเดินหายใจ'
			WHEN Source_Definition_Code = '096'   THEN      'ศัลยกรรมกระดูก'
			WHEN Source_Definition_Code = '097'   THEN      'ตึกผู้ป่วยพิเศษชั้น6'
			WHEN Source_Definition_Code = '098'   THEN      'จุดซักประวัติธาลัสซีเมียเด็ก'
			WHEN Source_Definition_Code = '099'   THEN      'คลินิกฝังเข็ม'
			WHEN Source_Definition_Code = '100'   THEN      'ERเสริม'
			WHEN Source_Definition_Code = '101'   THEN      'ตึกศัลยกรรมกระดูก'
			WHEN Source_Definition_Code = '102'   THEN      'ตึกICU'
			WHEN Source_Definition_Code = '103'   THEN      'ห้องผ่าตัดเล็ก'
			WHEN Source_Definition_Code = '104'   THEN      'จุดเรียกคิวConsultนอกเวลา'
			WHEN Source_Definition_Code = '105'   THEN      'ห้องให้คำปรึกษา'
			WHEN Source_Definition_Code = '106'   THEN      'ตึกCOHORT'
			WHEN Source_Definition_Code = '107'   THEN      'คลิกนิกARI'
			WHEN Source_Definition_Code = '108'   THEN      'ARI ศูนย์พักคอย'
			WHEN Source_Definition_Code = '109'   THEN      'ห้องตรวจARI'
			WHEN Source_Definition_Code = '110'   THEN      'คลินิกกัญชา(พฤหัสบดี)'
			WHEN Source_Definition_Code = '111'   THEN      'ตึกผู้ป่วยพิเศษชั้น5'
			WHEN Source_Definition_Code = '112'   THEN      'จุดซักประวัติortho'
			WHEN Source_Definition_Code = '113'   THEN      'คลินิควัคซีน Covid 19'
			WHEN Source_Definition_Code = '114'   THEN      'ห้องตรวจเบาหวาน'
			WHEN Source_Definition_Code = '115'   THEN      'ห้องตรวจความดันโลหิตสูง'
			WHEN Source_Definition_Code = '116'   THEN      'ห้องตรวจโรคไตวายเรื้อรัง'
			WHEN Source_Definition_Code = '117'   THEN      'จุดซักประวัติCAPD'
			WHEN Source_Definition_Code = '118'   THEN      'จุดซักประวัติPalliative Care'
			WHEN Source_Definition_Code = '119'   THEN      'ห้องจ่ายยาTeleMedicine'
			WHEN Source_Definition_Code = '120'   THEN      'ตึกCOHORT2(ICUเก่า)'
			WHEN Source_Definition_Code = '121'   THEN      'ตึกCOHORT3(ชั้น6)'
			WHEN Source_Definition_Code = '122'   THEN      'ห้องยาศูนย์พักคอย'
			WHEN Source_Definition_Code = '123'   THEN      'ห้องจ่ายยา NCD'
			WHEN Source_Definition_Code = '124'   THEN      'ห้องจ่ายเงิน NCD'
			WHEN Source_Definition_Code = '125'   THEN      'ห้องจ่ายยาผู้ป่วยใน'
			WHEN Source_Definition_Code = '126'   THEN      'จุดซักประวัติคลินิควัคซีนCovid 19'
			WHEN Source_Definition_Code = '127'   THEN      'จุดซักประวัติ Self Isolation'
			WHEN Source_Definition_Code = '128'   THEN      'ห้องตรวจ Self Isolation'
			WHEN Source_Definition_Code = '129'   THEN      'จุดซักประวัติ Home Isolation'
			WHEN Source_Definition_Code = '130'   THEN      'ห้องตรวจ Home Isolation'
			WHEN Source_Definition_Code = '131'   THEN      'ห้องจำหน่ายผู้ป่วย Home Isolatio'
			WHEN Source_Definition_Code = '132'   THEN      'จุดซักประวัติERบ่ายเสริม'
			WHEN Source_Definition_Code = '133'   THEN      'ห้องตรวจสุขภาพจิตเด็กและวัยรุ่น'
			WHEN Source_Definition_Code = '134'   THEN      'จุดซักประวัติสุขภาพจิต'
			WHEN Source_Definition_Code = '135'   THEN      'จุดซักประวัติฝากครรภ์'
			WHEN Source_Definition_Code = '136'   THEN      'ห้องให้คำปรึกษาสุขภาพจิต'
			WHEN Source_Definition_Code = '137'   THEN      'ห้องรอฉีดยา'
			WHEN Source_Definition_Code = '138'   THEN      'ห้องตรวจพัฒนาการเด็ก'
			WHEN Source_Definition_Code = '139'   THEN      'CTscan'
			WHEN Source_Definition_Code = '999'   THEN      'กลับบ้าน'
			WHEN Source_Definition_Code = '01'    THEN      'ตึกชาย'
			WHEN Source_Definition_Code = '02'    THEN      'ตึกหญิง'
			WHEN Source_Definition_Code = '03'    THEN      'ตึกเด็ก'
			WHEN Source_Definition_Code = '05'    THEN      'ตึกคลอด'
			WHEN Source_Definition_Code = '06'    THEN      'ตึกผู้ป่วยพิเศษชั้น6'
			WHEN Source_Definition_Code = '07'    THEN      'ตึกสูติ-นารีเวช'
			WHEN Source_Definition_Code = '08'    THEN      'ตึกศัลยกรรม'
			WHEN Source_Definition_Code = '09'    THEN      'ตึกศัลยกรรมกระดูก'
			WHEN Source_Definition_Code = '10'    THEN      'ตึกICU'
			WHEN Source_Definition_Code = '11'    THEN      'ตึกติดเชื้อ'
			WHEN Source_Definition_Code = '12'    THEN      'ตึกผู้ป่วยพิเศษชั้น5'
			WHEN Source_Definition_Code = '13'    THEN      'ตึกCOHORT3(ชั้น6)'
			WHEN Source_Definition_Code = '14'    THEN      'ตึกCOHORT2(ICUเก่า)'
			WHEN Source_Definition_Code = '15'    THEN      'CIสังขะ_HI'
			WHEN Source_Definition_Code = '16'    THEN      'CIกระเทียม_KT'
			WHEN Source_Definition_Code = '17'    THEN      'CIทับทัน_TA'
			WHEN Source_Definition_Code = '18'    THEN      'CIเทพรักษา_TR'
			WHEN Source_Definition_Code = '19'    THEN      'CIขอนแตก_KK'
			WHEN Source_Definition_Code = '20'    THEN      'CIพระแก้ว_PK'
			WHEN Source_Definition_Code = '21'    THEN      'CIดม_DM'
			WHEN Source_Definition_Code = '22'    THEN      'CIสะกาด_SK'
			WHEN Source_Definition_Code = '23'    THEN      'CIตาคง_TK'
			WHEN Source_Definition_Code = '24'    THEN      'CIตาตุม+ตาแตรว_TT'
			WHEN Source_Definition_Code = '25'    THEN      'CIบ้านจารย์_BJ'
			WHEN Source_Definition_Code = '26'    THEN      'CIชบ_CP'
			WHEN Source_Definition_Code = '27'    THEN      'CIโดง_DO'
			WHEN Source_Definition_Code = '28'    THEN      'ตึกAKT'
			WHEN Source_Definition_Code = '29'    THEN      'ตึกCOHORT4'
			WHEN Source_Definition_Code = '30'    THEN      'ทารกแรกเกิด(Neonatal ward)'
			
			
	ELSE Source_Definition_Name -- ถ้าไม่ตรงกับเงื่อนไขใด ๆ ให้เก็บค่าเดิม
END,
Source_Group_Code = CASE

			WHEN Source_Definition_Code = '000'	  THEN	'OPD'
            WHEN Source_Definition_Code = '001'   THEN  'OPD'
            WHEN Source_Definition_Code = '002'   THEN  'OPD'
            WHEN Source_Definition_Code = '003'   THEN  'OPD'
            WHEN Source_Definition_Code = '004'   THEN  'OPD'
            WHEN Source_Definition_Code = '005'   THEN  'OPD'
            WHEN Source_Definition_Code = '006'   THEN  'OPD'
            WHEN Source_Definition_Code = '007'   THEN  'OPD'
            WHEN Source_Definition_Code = '008'   THEN  'OPD'
            WHEN Source_Definition_Code = '009'   THEN  'IPD'
            WHEN Source_Definition_Code = '010'   THEN  'OPD'
            WHEN Source_Definition_Code = '011'   THEN  'OPD'
            WHEN Source_Definition_Code = '012'   THEN  'OPD'
            WHEN Source_Definition_Code = '013'   THEN  'OPD'
            WHEN Source_Definition_Code = '014'   THEN  'OPD'
            WHEN Source_Definition_Code = '015'   THEN  'OPD'
            WHEN Source_Definition_Code = '016'   THEN  'OPD'
            WHEN Source_Definition_Code = '017'   THEN  'IPD'
            WHEN Source_Definition_Code = '018'   THEN  'OPD'
            WHEN Source_Definition_Code = '019'   THEN  'OPD'
            WHEN Source_Definition_Code = '020'   THEN  'OPD'
            WHEN Source_Definition_Code = '021'   THEN  'OPD'
            WHEN Source_Definition_Code = '022'   THEN  'OPD'
            WHEN Source_Definition_Code = '023'   THEN  'OPD'
            WHEN Source_Definition_Code = '024'   THEN  'OPD'
            WHEN Source_Definition_Code = '025'   THEN  'OPD'
            WHEN Source_Definition_Code = '026'   THEN  'OPD'
            WHEN Source_Definition_Code = '027'   THEN  'OPD'
            WHEN Source_Definition_Code = '028'   THEN  'OPD'
            WHEN Source_Definition_Code = '029'   THEN  'OPD'
            WHEN Source_Definition_Code = '030'   THEN  'OPD'
            WHEN Source_Definition_Code = '031'   THEN  'OPD'
            WHEN Source_Definition_Code = '032'   THEN  'OPD'
            WHEN Source_Definition_Code = '033'   THEN  'OPD'
            WHEN Source_Definition_Code = '034'   THEN  'OPD'
            WHEN Source_Definition_Code = '035'   THEN  'OPD'
            WHEN Source_Definition_Code = '036'   THEN  'OPD'
            WHEN Source_Definition_Code = '037'   THEN  'OPD'
            WHEN Source_Definition_Code = '038'   THEN  'IPD'
            WHEN Source_Definition_Code = '039'   THEN  'OPD'
            WHEN Source_Definition_Code = '040'   THEN  'OPD'
            WHEN Source_Definition_Code = '041'   THEN  'OPD'
            WHEN Source_Definition_Code = '042'   THEN  'OPD'
            WHEN Source_Definition_Code = '043'   THEN  'OPD'
            WHEN Source_Definition_Code = '044'   THEN  'OPD'
            WHEN Source_Definition_Code = '045'   THEN  'OPD'
            WHEN Source_Definition_Code = '046'   THEN  'OPD'
            WHEN Source_Definition_Code = '047'   THEN  'OPD'
            WHEN Source_Definition_Code = '048'   THEN  'OPD'
            WHEN Source_Definition_Code = '049'   THEN  'OPD'
            WHEN Source_Definition_Code = '050'   THEN  'OPD'
            WHEN Source_Definition_Code = '051'   THEN  'OPD'
            WHEN Source_Definition_Code = '052'   THEN  'OPD'
            WHEN Source_Definition_Code = '053'   THEN  'OPD'
            WHEN Source_Definition_Code = '054'   THEN  'IPD'
            WHEN Source_Definition_Code = '055'   THEN  'OPD'
            WHEN Source_Definition_Code = '056'   THEN  'OPD'
            WHEN Source_Definition_Code = '057'   THEN  'OPD'
            WHEN Source_Definition_Code = '058'   THEN  'OPD'
            WHEN Source_Definition_Code = '059'   THEN  'OPD'
            WHEN Source_Definition_Code = '060'   THEN  'OPD'
            WHEN Source_Definition_Code = '061'   THEN  'OPD'
            WHEN Source_Definition_Code = '062'   THEN  'OPD'
            WHEN Source_Definition_Code = '063'   THEN  'OPD'
            WHEN Source_Definition_Code = '064'   THEN  'OPD'
            WHEN Source_Definition_Code = '065'   THEN  'OPD'
            WHEN Source_Definition_Code = '066'   THEN  'OPD'
            WHEN Source_Definition_Code = '067'   THEN  'OPD'
            WHEN Source_Definition_Code = '068'   THEN  'OPD'
            WHEN Source_Definition_Code = '069'   THEN  'OPD'
            WHEN Source_Definition_Code = '070'   THEN  'OPD'
            WHEN Source_Definition_Code = '071'   THEN  'OPD'
            WHEN Source_Definition_Code = '072'   THEN  'OPD'
            WHEN Source_Definition_Code = '073'   THEN  'OPD'
            WHEN Source_Definition_Code = '074'   THEN  'OPD'
            WHEN Source_Definition_Code = '075'   THEN  'OPD'
            WHEN Source_Definition_Code = '076'   THEN  'OPD'
            WHEN Source_Definition_Code = '077'   THEN  'OPD'
            WHEN Source_Definition_Code = '078'   THEN  'OPD'
            WHEN Source_Definition_Code = '079'   THEN  'OPD'
            WHEN Source_Definition_Code = '080'   THEN  'IPD'
            WHEN Source_Definition_Code = '081'   THEN  'IPD'
            WHEN Source_Definition_Code = '082'   THEN  'IPD'
            WHEN Source_Definition_Code = '083'   THEN  'IPD'
            WHEN Source_Definition_Code = '084'   THEN  'IPD'
            WHEN Source_Definition_Code = '085'   THEN  'OPD'
            WHEN Source_Definition_Code = '086'   THEN  'OPD'
            WHEN Source_Definition_Code = '087'   THEN  'OPD'
            WHEN Source_Definition_Code = '088'   THEN  'OPD'
            WHEN Source_Definition_Code = '089'   THEN  'OPD'
            WHEN Source_Definition_Code = '090'   THEN  'OPD'
            WHEN Source_Definition_Code = '091'   THEN  'OPD'
            WHEN Source_Definition_Code = '092'   THEN  'OPD'
            WHEN Source_Definition_Code = '093'   THEN  'OPD'
            WHEN Source_Definition_Code = '094'   THEN  'OPD'
            WHEN Source_Definition_Code = '095'   THEN  'OPD'
            WHEN Source_Definition_Code = '096'   THEN  'IPD'
            WHEN Source_Definition_Code = '097'   THEN  'IPD'
            WHEN Source_Definition_Code = '098'   THEN  'OPD'
            WHEN Source_Definition_Code = '099'   THEN  'OPD'
            WHEN Source_Definition_Code = '100'   THEN  'OPD'
            WHEN Source_Definition_Code = '101'   THEN  'IPD'
            WHEN Source_Definition_Code = '102'   THEN  'IPD'
            WHEN Source_Definition_Code = '103'   THEN  'IPD'
            WHEN Source_Definition_Code = '104'   THEN  'OPD'
            WHEN Source_Definition_Code = '105'   THEN  'OPD'
            WHEN Source_Definition_Code = '106'   THEN  'IPD'
            WHEN Source_Definition_Code = '107'   THEN  'OPD'
            WHEN Source_Definition_Code = '108'   THEN  'OPD'
            WHEN Source_Definition_Code = '109'   THEN  'OPD'
            WHEN Source_Definition_Code = '110'   THEN  'OPD'
            WHEN Source_Definition_Code = '111'   THEN  'IPD'
            WHEN Source_Definition_Code = '112'   THEN  'OPD'
            WHEN Source_Definition_Code = '113'   THEN  'OPD'
            WHEN Source_Definition_Code = '114'   THEN  'OPD'
            WHEN Source_Definition_Code = '115'   THEN  'OPD'
            WHEN Source_Definition_Code = '116'   THEN  'OPD'
            WHEN Source_Definition_Code = '117'   THEN  'OPD'
            WHEN Source_Definition_Code = '118'   THEN  'OPD'
            WHEN Source_Definition_Code = '119'   THEN  'OPD'
            WHEN Source_Definition_Code = '120'   THEN  'IPD'
            WHEN Source_Definition_Code = '121'   THEN  'IPD'
            WHEN Source_Definition_Code = '122'   THEN  'OPD'
            WHEN Source_Definition_Code = '123'   THEN  'OPD'
            WHEN Source_Definition_Code = '124'   THEN  'OPD'
            WHEN Source_Definition_Code = '125'   THEN  'OPD'
            WHEN Source_Definition_Code = '126'   THEN  'OPD'
            WHEN Source_Definition_Code = '127'   THEN  'OPD'
            WHEN Source_Definition_Code = '128'   THEN  'OPD'
            WHEN Source_Definition_Code = '129'   THEN  'OPD'
            WHEN Source_Definition_Code = '130'   THEN  'OPD'
            WHEN Source_Definition_Code = '131'   THEN  'OPD'
            WHEN Source_Definition_Code = '132'   THEN  'OPD'
            WHEN Source_Definition_Code = '133'   THEN  'OPD'
            WHEN Source_Definition_Code = '134'   THEN  'OPD'
            WHEN Source_Definition_Code = '135'   THEN  'OPD'
            WHEN Source_Definition_Code = '136'   THEN  'OPD'
            WHEN Source_Definition_Code = '137'   THEN  'OPD'
            WHEN Source_Definition_Code = '138'   THEN  'OPD'
            WHEN Source_Definition_Code = '139'   THEN  'OPD'
            WHEN Source_Definition_Code = '999'   THEN  'OPD'
            WHEN Source_Definition_Code = '01'    THEN  'IPD'
            WHEN Source_Definition_Code = '02'    THEN  'IPD'
            WHEN Source_Definition_Code = '03'    THEN  'IPD'
            WHEN Source_Definition_Code = '05'    THEN  'IPD'
            WHEN Source_Definition_Code = '06'    THEN  'IPD'
            WHEN Source_Definition_Code = '07'    THEN  'IPD'
            WHEN Source_Definition_Code = '08'    THEN  'IPD'
            WHEN Source_Definition_Code = '09'    THEN  'IPD'
            WHEN Source_Definition_Code = '10'    THEN  'IPD'
            WHEN Source_Definition_Code = '11'    THEN  'IPD'
            WHEN Source_Definition_Code = '12'    THEN  'IPD'
            WHEN Source_Definition_Code = '13'    THEN  'IPD'
            WHEN Source_Definition_Code = '14'    THEN  'IPD'
            WHEN Source_Definition_Code = '15'    THEN  'IPD'
            WHEN Source_Definition_Code = '16'    THEN  'IPD'
            WHEN Source_Definition_Code = '17'    THEN  'IPD'
            WHEN Source_Definition_Code = '18'    THEN  'IPD'
            WHEN Source_Definition_Code = '19'    THEN  'IPD'
            WHEN Source_Definition_Code = '20'    THEN  'IPD'
            WHEN Source_Definition_Code = '21'    THEN  'IPD'
            WHEN Source_Definition_Code = '22'    THEN  'IPD'
            WHEN Source_Definition_Code = '23'    THEN  'IPD'
            WHEN Source_Definition_Code = '24'    THEN  'IPD'
            WHEN Source_Definition_Code = '25'    THEN  'IPD'
            WHEN Source_Definition_Code = '26'    THEN  'IPD'
            WHEN Source_Definition_Code = '27'    THEN  'IPD'
            WHEN Source_Definition_Code = '28'    THEN  'IPD'
            WHEN Source_Definition_Code = '29'    THEN  'IPD'
            WHEN Source_Definition_Code = '30'    THEN  'IPD'
	ELSE Source_Group_Code -- ถ้าไม่ตรงกับเงื่อนไขใด ๆ ให้เก็บค่าเดิม
END

WHERE Source_Definition_Code IN (
    '000','001','002','003','004','005','006','007','008','009','010','011','012','013','014','015','016','017','018','019','020','021','022','023','024','025','026','027','028','029','030','031','032','033','034','035','036','037','038','039','040','041','042','043','044','045','046','047','048','049','050','051','052','053','054','055','056','057','058','059','060','061','062','063','064','065','066','067','068','069','070','071','072','073','074','075','076','077','078','079','080','081','082','083','084','085','086','087','088','089','090','091','092','093','094','095','096','097','098','099','100','101','102','103','104','105','106','107','108','109','110','111','112','113','114','115','116','117','118','119','120','121','122','123','124','125','126','127','128','129','130','131','132','133','134','135','136','137','138','139','999','01','02','03','05','06','07','08','09','10','11','12','13','14','15','16','17','18','19','20','21','22','23','24','25','26','27','28','29','30' -- รายการ Source_Definition_Code ที่ต้องการอัปเดต
    -- เพิ่มรายการ Source_Definition_Code อื่น ๆ ต่อไป
	
);

Option Explicit
Sub TimeRightNow()
Dim T as Date		//Declare Variable 
T = now				//Give Variable T return Value of now function

MsgBox Format(T, "mm-dd-yyyy mm:hh")	//Display Formatted Date 

End Sub

Sub IncrCell()
Dim A as Integer 	// Variable declaration
A = 1					// Giving Variable A the Value 1

Range("A1").Value = Range("A1").Value + A  // This will Increase Cell A1 by "A"

End Sub

Sub FindExample()
    Dim searchRange As Range
    Dim foundCell As Range
    
    ' Set the range to search in (e.g., column A)
    Set searchRange = Range("A1:A10")
    
    ' Find the value "SearchValue" within the search range
    Set foundCell = searchRange.Find("SearchValue")
    
    ' Check if the value was found
    If Not foundCell Is Nothing Then
        ' Value was found
        MsgBox "Value found at cell " & foundCell.Address
    Else
        ' Value was not found
        MsgBox "Value not found"
    End If
End Sub

Sub find_method()
Dim cell As Range
Dim search_range As Range
Application.DisplayAlerts = False
On Error Resume Next
Set search_range = Application.InputBox("Select Your Range of Cells", "Search Range", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If search_range Is Nothing Then
Exit Sub
End If

For Each cell In search_range
Set cell = cell.Find("Mr.")
If Not cell Is Nothing Then
cell.Offset(0, 1).Value = "Male"
End If
Next cell

For Each cell In search_range
Set cell = cell.Find("Ms.")
If Not cell Is Nothing Then
cell.Offset(0, 1).Value = "Female"
End If
Next cell
MsgBox "Done"
End Sub

/****** Script for SelectTopNRows command from SSMS  ******/
SELECT 
      [LN]
      ,[HN]
      ,[FULLNAME]
     , [YEAR]

  
      ,[SEX]
      ,[BIRTHDATE]
    
      ,[WARD NAME]
      ,[PATIENT TYPE NAME]
      ,[DOCTOR NAME]
  
      ,[AN]
      ,[VN]
     ,[ORDER DATETIME]
       ,[IREQ_LAST_CHK_DT] as 'Checkin datetime'

      ,[RES ITEM NAME]
      ,[RES ITEM RESULT]

      ,[RES ITEM REPORT DATETIME]
      ,[RES ITEM REPORT STAFF NAME]
      ,[RES ITEM APPROVE DATETIME]
      ,[RES ITEM APPROVE STAFF NAME] 

--      ,[IREQ_LAST_APP_DT]
  FROM [LAB_DB].[dbo].[view_lab_statistic_Result_List]
  where [RES ITEM STATE] = 'A' and  HN in (SELECT  distinct HN
  FROM [LAB_DB].[dbo].[view_lab_statistic_Result_List]
  where [RES ITEM CODE] in ('IM1429','IM1430','IM1433','IM1448') and ([IREQ_LAST_CHK_DT] Between '@dt1' and '@dt2')) and [RES ITEM CODE] in ('IM1429','IM1430','IM1433','IM1448')
  

// 
// 24-8-65
if {RequestInfo.Report_By} = 'มัทนาวดี' then  'จพ.วิทยา'
else if {RequestInfo.Report_By} = 'สายทิพย์ ' then  'จพ.งาน'
else if {RequestInfo.Report_By} = 'ทนพ.ญ. ญาณิศา0' then  'Laboratory'
else if {RequestInfo.Report_By} = 'เข็มทอง' then  'Laboratory'
else if {RequestInfo.Report_By} = 'ทนพ.ญ.วัลดี  ' then  'Laboratory'
else if {RequestInfo.Report_By} = 'นายขวัญชัย สม0' then  'นักเทคนิคการแพทย์ชำนาญการ'
else if {RequestInfo.Report_By} = 'จริยา อิน' then  'นักเทคนิคการแพทย์'
else if {RequestInfo.Report_By} = 'administrator' then  'Administrator LIS'

Sub DeleteEntireRow()
Selection.EntireRow.Delete
End Sub

Sub DeleteBlankRows()
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Sub MoveToEnd()
    Dim xRg As Range
    Dim xTxt As String
    Dim xCell As Range
    Dim xEndRow As Long
    Dim I As Long
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
lOne:
    Set xRg = Application.InputBox("Select range:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    If xRg.Columns.Count > 1 Or xRg.Areas.Count > 1 Then
        MsgBox " Multiple ranges or columns have been selected ", vbInformation, "Kutools for Excel"
        GoTo lOne
    End If
    xEndRow = xRg.Rows.Count + xRg.Row
    Application.ScreenUpdating = False
    For I = xRg.Rows.Count To 1 Step -1
        If xRg.Cells(I) = "Done" Then
           xRg.Cells(I).EntireRow.Cut
           Rows(xEndRow).Insert Shift:=xlDown
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Sub InsertPictures()
'Update 20140513
Dim PicList() As Variant
Dim PicFormat As String
Dim Rng As Range
Dim sShape As Shape
On Error Resume Next
PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
xColIndex = Application.ActiveCell.Column
If IsArray(PicList) Then
    xRowIndex = Application.ActiveCell.Row
    For lLoop = LBound(PicList) To UBound(PicList)
        Set Rng = Cells(xRowIndex, xColIndex)
        Set sShape = ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
        xRowIndex = xRowIndex + 1
    Next
End If
End Sub

'In this Example I am Copying the File From "C:Temp" Folder to "D:Job" Folder
Sub sbCopyingAFile()

'Declare Variables
Dim FSO
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String

'This is Your File Name which you want to Copy
sFile = "Sample.xls"

'Change to match the source folder path
sSFolder = "C:Temp"

'Change to match the destination folder path
sDFolder = "D:Job"

'Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")

'Checking If File Is Located in the Source Folder
If Not FSO.FileExists(sSFolder & sFile) Then
    MsgBox "Specified File Not Found", vbInformation, "Not Found"
    
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & sFile) Then
    FSO.CopyFile (sSFolder & sFile), sDFolder, True
    MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
Else
    MsgBox "Specified File Already Exists In The Destination Folder", vbExclamation, "File Already Exists"
End If

End Sub

Sub CreateValueFile()
  Dim wbCurr As Workbook, wbOut As Workbook
  Dim sName As String
  Dim sSheet As Worksheet, CurSheet As Worksheet
  Dim strFileExists As String
  
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Application.EnableEvents = False   'To avoid problems with Titus
  
  
  Set wbCurr = ThisWorkbook
  'Copy output template to output file
  sName = "C:\Users\ah19053\Aon\Bosch 2022 Global Actuary RFP - Central documents\040. Local fee collection\Bosch_2022_Fees_Template_v01.xlsx"
  Set wbOut = Workbooks.Open(Filename:=sName, UpdateLinks:=0)
  sName = "C:\Users\ah19053\Aon\Bosch 2022 Global Actuary RFP - Central documents\040. Local fee collection\Bosch_2022_Fees_v01.xlsx"
  strFileExists = Dir(sName)
  If strFileExists = "" Then
  Else
    Kill sName
  End If
  On Error GoTo 0
  wbOut.SaveAs Filename:=sName
  
  'loop through worksheets
  For Each sSheet In wbCurr.Worksheets
    If InStr(1, sSheet.Name, "Pricing") > 0 Then
      sSheet.Copy after:=wbOut.Sheets(wbOut.Sheets.Count)
      wbOut.Sheets(wbOut.Sheets.Count).Select
      Cells.Select
      Selection.Copy
      Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
      Application.CutCopyMode = False
      Range("a1").Select
      
      'Set CurSheet = wbOut.Sheets.Add
      
      'Debug.Print sSheet.Name
    End If
  Next sSheet
  
  wbOut.Save
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  MsgBox ("Program finished")
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"

Private Sub Create_Folder()
'CREATE FOLDER'

Dim ToPath As String

ToPath = ThisWorkbook.Worksheets("1").Range("A1").Value
MkDir ToPath

End Sub


Sub Copy_One_File()
    FileCopy "C:\Users\Ron\SourceFolder\Test.xls", "C:\Users\Ron\DestFolder\Test.xls"
End Sub

Sub Move_Rename_One_File()
'You can change the path and file name'
    Name "C:\Users\Ron\SourceFolder\Test.xls" As "C:\Users\Ron\DestFolder\TestNew.xls"
End Sub

Sub Delete_One_File()
'You can change the path and file name'
    Kill "C:\Users\Ron\SourceFolder\Test.xls"
End Sub
 
'Copy or move more files or complete folders'
'Note: Read the commented code lines in the code'

Sub Copy_Folder()
'This example copy all files and subfolders from FromPath to ToPath'
'Note: If ToPath already exist it will overwrite existing files in this folder'
'if ToPath not exist it will be made for you'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\Test"    '<< Change'

    'If you want to create a backup of your folder every time you run this macro'
    'you can create a unique folder with a Date/Time stamp.'
    'ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss").'

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    FSO.CopyFolder Source:=FromPath, Destination:=ToPath
    MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath

End Sub

Sub Move_Rename_Folder()
'This example move the folder from FromPath to ToPath'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\Test"    '<< Change'
    'Note: It is not possible to use a folder that exist in ToPath'

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = True Then
        MsgBox ToPath & " exist, not possible to move to a existing folder"
        Exit Sub
    End If

    FSO.MoveFolder Source:=FromPath, Destination:=ToPath
    MsgBox "The folder is moved from " & FromPath & " to " & ToPath

End Sub


Sub Copy_Files_Dates()
'This example copy all files between certain dates from FromPath to ToPath'
'You can also use this to copy the files from the last ? days'
'If Fdate >= Date - 30 Then'
'Note: If the files in ToPath already exist it will overwrite'
'existing files in this folder'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim Fdate As Date
    Dim FileInFromFolder As Object

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\Test"    '<< Change'

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    If Right(ToPath, 1) <> "\" Then
        ToPath = ToPath & "\"
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = False Then
        MsgBox ToPath & " doesn't exist"
        Exit Sub
    End If

    For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
        If Fdate >= DateSerial(2006, 10, 1) And Fdate <= DateSerial(2006, 11, 1) Then
            FileInFromFolder.Copy ToPath
        End If
    Next FileInFromFolder

    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub


Sub Copy_Certain_Files_In_Folder()
'This example copy all Excel files from FromPath to ToPath'
'Note: If the files in ToPath already exist it will overwrite'
'existing files in this folder'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim FileExt As String

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\Test"    '<< Change'

    FileExt = "*.xl*"  '<< Change
    'You can use *.* for all files or *.doc for Word files'

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = False Then
        MsgBox ToPath & " doesn't exist"
        Exit Sub
    End If

    FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub

Sub Move_Certain_Files_To_New_Folder()
'This example move all Excel files from FromPath to ToPath'
'Note: It will create the folder ToPath for you with a date-time stamp'
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim FileExt As String
    Dim FNames As String

    FromPath = "C:\Users\Ron\Data"  '<< Change'
    ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss") _
           & " Excel Files" & "\"    '<< Change only the destination folder'

    FileExt = "*.xl*"   '<< Change'
    'You can use *.* for all files or *.doc for word files'

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    FNames = Dir(FromPath & FileExt)
    If Len(FNames) = 0 Then
        MsgBox "No files in " & FromPath
        Exit Sub
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    FSO.CreateFolder (ToPath)

    FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub

'VBA Deleting All Files and Subfolders'
Sub VBAF1_Delete_All_Files_and_Subfolders()
    
    'Variable declaration'
    Dim sFolderPath As String
    Dim FSO As Object
    
     'Define Folder Path'
    sFolderPath = "C:\VBAF1\Test\"
    
    'Check if slash is added'
    If Right(sFolderPath, 1) = "\" Then
        'If added remove it from the specified path'
        sFolderPath = Left(sFolderPath, Len(sFolderPath) - 1)
    End If
            
    'Create FSO Object'
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    'Check Specified Folder exists or not'
    If FSO.FolderExists(sFolderPath) Then
    
          'Delete All Files'
          FSO.DeleteFile sFolderPath & "\*.*", True
                        
          'Delete All Subfolders'
		  'Change the code'
          FSO.DeleteFolder sFolderPath & "\*.*", True

			
		 'Remark Sample:'
		 'Sample Delete File in Folder Download "C:\Users\Downloads\"'
		 'FSO.DeleteFolder sFolderPath & "\*.*", True'

		 'Sample Delete Folder in Folder Download "C:\Users\Downloads\FOLDER1\"'
		 'FSO.DeleteFolder sFolderPath , True'
          
     End If
    
End Sub

Public Function AllProcs(ByVal strDatabasePath As String, ByVal strModuleName As String)
    Dim appAccess As Access.Application
    Dim db As Database
    Dim mdl As Module
    Dim lngCount As Long
    Dim lngCountDecl As Long
    Dim lngI As Long
    Dim strProcName As String
    Dim astrProcNames() As String
    Dim intI As Integer
    Dim strMsg As String
    Dim lngR As Long

    Set appAccess = New Access.Application

    appAccess.OpenCurrentDatabase strDatabasePath
    ' Open specified Module object.
    appAccess.DoCmd.OpenModule strModuleName
    ' Return reference to Module object.
    Set mdl = appAccess.Modules(strModuleName)
    ' Count lines in module.
    lngCount = mdl.CountOfLines
    ' Count lines in Declaration section in module.
    lngCountDecl = mdl.CountOfDeclarationLines
    ' Determine name of first procedure.
    strProcName = mdl.ProcOfLine(lngCountDecl + 1, lngR)
    ' Initialize counter variable.
    intI = 0        ' Redimension array.
    ReDim Preserve astrProcNames(intI)
    ' Store name of first procedure in array.
    astrProcNames(intI) = strProcName
    ' Determine procedure name for each line after declarations.
    For lngI = lngCountDecl + 1 To lngCount
        ' Compare procedure name with ProcOfLine property value.
        If strProcName <> mdl.ProcOfLine(lngI, lngR) Then
            ' Increment counter.
            intI = intI + 1
            strProcName = mdl.ProcOfLine(lngI, lngR)
            ReDim Preserve astrProcNames(intI)
            ' Assign unique procedure names to array.
            astrProcNames(intI) = strProcName
        End If
    Next lngI
    strMsg = "Procedures in module '" & strModuleName & "': " & vbCrLf & vbCrLf
    For intI = 0 To UBound(astrProcNames)
        strMsg = strMsg & astrProcNames(intI) & vbCrLf
    Next intI
    ' Message box listing all procedures in module.
    Debug.Print strMsg
    appAccess.CloseCurrentDatabase
    appAccess.Quit
    Set appAccess = Nothing
End Function

Public Sub SolveFive(Optional ShowAlert As Boolean = True)

'Purpose    : Runs Solver Loops through the '5YrChoice_MVoptions' Tab
'Author     : Jimmy Briggs <jimmy.briggs@pwc.com>
'Description: Automate Workflow for RLUS Client
'Date       : 2022-02-04

 Application.ScreenUpdating = False
 Application.DisplayStatusBar = True
 Application.Cursor = xlWait
 On Error GoTo HandleError

 Dim changeCells As Range
 Dim Result As Integer
 Dim i As Integer
 Dim StartTime As Double
 Dim SecondsElapsed As Double

 StartTime = Timer

 Application.StatusBar = "Starting Macro for 5YrChoice_MVoptions, please be patient..."

 Sheets("5YrChoice_MVoptions").Select

 For i = 3 To 62 Step 1
    Application.StatusBar = "Running Solver on iteration " & i & " out of 62."
    Set changeCells = ActiveSheet.Range(Range(Cells(i, 28).Address, Cells(i, 29).Address).Address)
    SolverReset
    SolverOptions precision:=0.000000001
    SolverOK SetCell:=Cells(i, 35).Address, MaxMinVal:=2, byChange:=changeCells.Address
    SolverAdd CellRef:=Cells(i, 36).Address, Relation:=2, FormulaText:=0
    SolverAdd CellRef:=changeCells.Address, Relation:=3, FormulaText:=0.0000000001
    Result = SolverSolve(True)

    If Result <= 3 Then
        SolverFinish KeepFinal:=1
    Else
        Beep
        MsgBox "Solver was unable to find a solution.", vbExclamation, "SOLUTION NOT FOUND"
        SolverFinish KeepFinal:=2
        GoTo Skip
    End If

Skip:
    SolverFinish KeepFinal:=2
    Next i

 Sheets("Comparison").Select
 SecondsElapsed = Round(Timer - StartTime, 2)
 Range("Latest_Execution_Time_5").Value = SecondsElapsed

 If ShowAlert = True Then
    MsgBox "Successfully ran code in " & SecondsElapsed & " seconds", vbInformation
 End If

 Application.StatusBar = "Done running Solver for sheet 5YrChoice_MVoptions."
 Application.OnTime Now + TimeValue("00:00:07"), "clearStatusBar"
 Application.ScreenUpdating = True

HandleExit:
    Application.Cursor = xlDefault
    Exit Sub
HandleError:
    MsgBox Err.Description
    Resume HandleExit

End Sub

let
    merge1 = Table.NestedJoin(Table1, {"ID"}, Table2, {"ID"}, "New", JoinKind.Inner),
    merge2= Table.NestedJoin(merge1, {"ID"}, Table3, {"ID"}, "Final", JoinKind.Inner)
in
    merge2

Sub ClearData()
 
Worksheets("Clients").Rows("2:" & Rows.Count).ClearContents
Worksheets("Cases").Rows("2:" & Rows.Count).ClearContents
Worksheets("Sessions").Rows("2:" & Rows.Count).ClearContents
 
End Sub

Sub Extracthyperlinks()
'Updateby Extendoffice
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "Extract URL"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
For Each Rng In WorkRng
    If Rng.Hyperlinks.Count > 0 Then
        Rng.Value = Rng.Hyperlinks.Item(1).Address
    End If
Next
End Sub

Public Function RefreshLinks(ByVal sDatabase As String) As Boolean
On Error GoTo ErrorOut
 
    'Refresh table links to a backend database
 
    Dim dbs As Database
    Dim tdf As TableDef
    Dim sCurrentTDF As String
 
    ' Loop through all tables in the database.
    Set dbs = CurrentDb
    For Each tdf In dbs.TableDefs
        ' If the table has a connect string, it's a linked table.
        If Len(tdf.Connect) > 0 Then
            tdf.Connect = "ODBC;Driver={SQL SERVER};" & "Server=DBSERVER\DB1;" & "Database=" & sDatabase & ";" & "Trusted_Connection=no;" & "Uid=sa;" & "Pwd=secret"
            Err = 0
            On Error Resume Next
            sCurrentTDF = tdf.Name
            tdf.RefreshLink ' Relink the table.
            If Err <> 0 Then
                RefreshLinks = False
                Exit Function
            End If
        End If
    Next tdf
 
    RefreshLinks = True
ExitOut:
    Exit Function
ErrorOut:
     msgBox ("There was an error refreshing the link(s) for '" & sCurrentTDF & "':  " & vbCrLf & vbCrLf & Err.Description)
     Resume ExitOut
End Function

=TEXT(D2; "JJJJ-MM-TT hh:mm:ss")

let
    Source = #"ChemWatch - All Expect User Fields Report"
in
    Source

Private Sub Select_Sector()

Dim rs As DAO.Recordset

Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")

Dim qdef As QueryDef
Set qdef = getCurrentDb.QueryDefs("qry_Select_Sector")
qdef.Connect = CurrentDb.TableDefs("BOCClientIndex").Connect


RegEx.Pattern = "IIf\(\[ServiceStatus\]=3,30,20\)\)=([0-9]+)"
qdef.SQL = RegEx.Replace(qdef.SQL, "IIf([ServiceStatus]=3,30,20))=" & [Forms]![MainMenu_Services]![SelectedStatusIndicator])

RegEx.Pattern = "\(View_qryServiceProviderOrganisationalStructure\.SectorCode\)=([0-9]+)"
qdef.SQL = RegEx.Replace(qdef.SQL, "(View_qryServiceProviderOrganisationalStructure.SectorCode)=" & [Forms]![MainMenu_Services]![SectorCode])


'For Testing purposes only - Do not use in production code
Set rs = qdef.OpenRecordset

Dim i As Long
For i = 0 To rs.Fields.Count - 1
        Debug.Print rs.Fields(i).Name,
    Next
    rs.MoveFirst
    Do Until rs.EOF
        Debug.Print
        For i = 0 To rs.Fields.Count - 1
            Debug.Print rs.Fields(i).value,
        Next
        rs.MoveNext
    Loop
End Sub

Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")

RegEx.Pattern = "\[UserID\]=([0-9]+)"
Set qdef = getCurrentDb.QueryDefs("Query Course List PASSTHRU")
qdef.SQL = RegEx.Replace(qdef.SQL, "[UserID]=" & getLoggedInUserID)


Query:
[Cost Centre Descriptions].[Sector Code] IN (

SELECT [SectorCode]
FROM [tbl_TRNG_PermissionsBySector] WITH (NOLOCK)
WHERE [UserID]=9999 AND ViewSector=1

)

Measure - Legal Compliance Rate = 
VAR Legal_BASELINE_VALUE =
	CALCULATE(
		COUNTA('95 Calc - Requirements Table'[IndividualID]),
		'95 Calc - Requirements Table'[Mixed Tag] IN {"Legal"}
	)
VAR Legal_MEASURE_VALUE = CALCULATE(COUNTA('95 Calc - Requirements Table'[IndividualID]), '95 Calc - Requirements Table'[Requirements Status (Group + Competency)] = "Compliant", '95 Calc - Requirements Table'[Mixed Tag] IN {"Legal"})

RETURN
	IF(
		NOT ISBLANK(Legal_MEASURE_VALUE),
		DIVIDE(Legal_MEASURE_VALUE, Legal_BASELINE_VALUE)
	)

Measure - Count of Worker - Role - Assigned % difference from Assigned = 
VAR __BASELINE_VALUE =
	CALCULATE(
		COUNTA('94 IndividualProjectCompany'[Worker - Role - Assigned]),
		'94 IndividualProjectCompany'[Worker - Role - Assigned]
			IN { "Assigned" }
	)
VAR __MEASURE_VALUE = COUNTA('94 IndividualProjectCompany'[Worker - Role - Assigned])
RETURN
	1-DIVIDE(__MEASURE_VALUE - __BASELINE_VALUE, __BASELINE_VALUE)

Table = 
FILTER(
    UNION(
        SELECTCOLUMNS('Table1',"Name",[Name],"Date",[Date],"Column1",[Column1]),
        SELECTCOLUMNS('Table1',"Name",[Name],"Date",[Date],"Column1",[Column2]),
        SELECTCOLUMNS('Table1',"Name",[Name],"Date",[Date],"Column1",[Column3]),
        SELECTCOLUMNS('Table1',"Name",[Name],"Date",[Date],"Column1",[Column4]),
        SELECTCOLUMNS('Table1',"Name",[Name],"Date",[Date],"Column1",[Column5]),
        SELECTCOLUMNS('Table1',"Name",[Name],"Date",[Date],"Column1",[Column6])
    ),
    [Column1]<>"")

Option Explicit

Sub q4()

 Dim q4a(1 To 25, 1 To 25) As Double
 Dim col As Integer, row As Integer
 
 For col = 1 To 25
 For row = 1 To 25
    q4a(row, col) = WorksheetFunction.RandBetween(100, 1000)
 Next row
 Next col
  
 range("B2").Resize(25, 25) = q4a

End Sub

Function exammax(bigrange As range) As String

Dim cell As range, maxval As Double

Set bigrange = range("B2:Z26")
maxval = range("B2")

For Each cell In bigrange
 If cell >= maxval Then maxval = cell
Next cell

exammax = maxval

End Function

Function exammin(bigrange As range) As String

Dim cell As range, minval As Double

Set bigrange = range("B2:Z26")
minval = range("B2")

For Each cell In bigrange
 If cell <= minval Then minval = cell
Next cell

exammin = minval

End Function

Sub sortino()

Dim bigrange As range, cell As range, counter As Integer, cellmean As Double

Set bigrange = range("B2:Z26")
cellmean = WorksheetFunction.Average(bigrange)
counter = 2

For Each cell In bigrange
    If cell <= cellmean Then
    Cells(28, counter) = cellmean - cell
    counter = counter + 1
    End If
    Next cell

range("A31") = "sortino ratio"
range("B31") = WorksheetFunction.Average(range(Cells(28, 2), Cells(28, counter)))

End Sub

Option Explicit

Function bscholes(rf As Double, so As Double, X As Double, sd As Double) As Double

Dim d1 As Double, d2 As Double, nd1 As Double, nd2 As Double, c As Double

d1 = (Log(so / X) + (rf + 0.5 * sd * sd) * 0.25) / (sd * Sqr(0.25))
d2 = d1 - (sd * Sqr(0.25))
nd1 = WorksheetFunction.Norm_S_Dist(d1, True)
nd2 = WorksheetFunction.Norm_S_Dist(d2, True)
c = so * nd1 - X * Exp(-rf * 0.25) * nd2

bscholes = c

End Function

Option Explicit
Sub mcSim()

    range("C16").Clear
    range("E3", "AL100").Clear

    Dim mcSim() As Double, mu As Double, iters As Integer, time As Integer
    Dim sd As Double, row As Integer, col As Integer

    
    time = InputBox("On which day would you like to exercise your option? (select a number between 1 and 63)")
    
    ReDim mcSim(1 To time, 1 To 30)
    iters = range("C17")
    range("B16").Value = "Selected exercise day"
    range("C16").Value = time

' Here you want to set the mean and stddev
' to whichever cell contains your inputs

    mu = range("C11")
    sd = range("C12")
    
    Randomize
    
   'i is rows, j is cols
   
    For col = 1 To iters
        For row = 1 To time
            mcSim(row, col) = mu + sd * WorksheetFunction.Norm_S_Inv(Rnd)
        Next row
    Next col

    range("F4").Resize(time, iters) = mcSim

    'label 2x2 array
    
    For col = 1 To 30
        For row = 1 To time
            Cells(row + 3, 5) = row
            Cells(3, col + 5) = col
        Next row
    Next col
    
    range("E3").Value = "Day"
    range(Cells(3, 5), Cells(time + 3, 5)).Interior.ColorIndex = 24
    range(Cells(3, 5), Cells(time + 3, 5)).HorizontalAlignment = xlCenter
    
End Sub
Sub FV1rand()

Dim col As Integer, row As Integer
Dim myrange As range
Dim time As Integer

time = range("C16")

For col = 6 To 35
    For row = 4 To time + 3
        Cells(row, 37) = 1 + Cells(row, col)
    Next row
    
    Set myrange = range(Cells(4, 37), Cells(time + 3, 37))
    Cells(time + 5, col) = WorksheetFunction.Product(myrange)
Next col
    
Cells(time + 5, 5) = "Future value of R1"
Cells(time + 5, 5).Interior.ColorIndex = 24

End Sub

Sub valuecalcs()

Dim col As Integer, row As Integer
Dim myrange As range
Dim time As Integer

time = range("C16")

Cells(time + 6, 5) = "ST"
Cells(time + 7, 5) = "X"
Cells(time + 8, 5) = "Max(ST-X,0)"
Cells(time + 9, 5) = "DCF"
Cells(time + 11, 5) = "Average DCF"


For col = 6 To 35
    Cells(time + 6, col) = WorksheetFunction.Product(Cells(time + 5, col), Cells(3, 3))
    Cells(time + 7, col) = range("C7")
    If Cells(time + 6, col) - Cells(time + 7, col) <= 0 Then
        Cells(time + 8, col) = 0
        Else
            Cells(time + 8, col) = Cells(time + 6, col) - Cells(time + 7, col)
        End If
    Cells(time + 9, col) = WorksheetFunction.Product(Cells(time + 8, col), Cells(14, 3))
    Next col
    
Set myrange = range(Cells(time + 9, 6), Cells(time + 9, 35))
Cells(time + 11, 6) = WorksheetFunction.Average(myrange)

Cells(time + 6, 5).Interior.ColorIndex = 24
Cells(time + 7, 5).Interior.ColorIndex = 24
Cells(time + 8, 5).Interior.ColorIndex = 24
Cells(time + 9, 5).Interior.ColorIndex = 24
Cells(time + 11, 5).Interior.ColorIndex = 17
Cells(time + 6, 5).HorizontalAlignment = xlCenter
Cells(time + 7, 5).HorizontalAlignment = xlCenter
Cells(time + 8, 5).HorizontalAlignment = xlCenter
Cells(time + 9, 5).HorizontalAlignment = xlCenter
Cells(time + 11, 5).HorizontalAlignment = xlCenter
    
End Sub

Option Explicit

Sub mcSim()

    Dim mcSim(1 To 63, 1 To 30) As Double, mu As Double
    Dim sd As Double, i As Integer, j As Integer

    mu = Range("C11")
    sd = Range("C12")
    
    Randomize
    
    'fill 2x2 array
    
    For j = 1 To 30
        For i = 1 To 63
            mcSim(i, j) = mu + sd * WorksheetFunction.Norm_S_Inv(Rnd)
        Next i
    Next j

    Range("F4").Resize(63, 30) = mcSim

    'label 2x2 array
    
    For j = 1 To 30
        For i = 1 To 63
            Cells(i + 3, 5) = i
            Cells(3, j + 5) = j
        Next i
    Next j

    
End Sub

Sub valuecalcs()

Dim col As Integer, row As Integer
Dim myrange As Range

For col = 6 To 35
    For row = 4 To 66
        Cells(row, 37) = 1 + Cells(row, col)
    Next row
    
    Set myrange = Range(Cells(4, 37), Cells(66, 37))
    Cells(68, col) = WorksheetFunction.Product(myrange)
Next col
    
Range("E68").Value = "Future value of R1"

End Sub

Sub valuecalcs2()

Dim col As Integer, row As Integer
Dim myrange As Range

Range("E69").Value = "ST"
Range("E70").Value = "X"
Range("E71").Value = "Max(ST-X,0)"
Range("E72").Value = "DCF"
Range("E74").Value = "Average DCF"


For col = 6 To 35
    Cells(69, col) = WorksheetFunction.Product(Cells(68, col), Cells(3, 3))
    Cells(70, col) = Range("C7")
    If Cells(69, col) - Cells(70, col) <= 0 Then
        Cells(71, col) = 0
        Else
            Cells(71, col) = Cells(69, col) - Cells(70, col)
        End If
    Cells(72, col) = WorksheetFunction.Product(Cells(71, col), Cells(14, 3))
    Next col
    
Set myrange = Range(Cells(72, 6), Cells(72, 35))
Cells(74, 6) = WorksheetFunction.Average(myrange)
    
End Sub

Option Explicit

Sub mcSim()

' This sub will populate a 30x10 array with
' values according to the formula in the revision
' lecture

    Dim mcSim(1 To 30, 1 To 10) As Double, mu As Double
    Dim sd As Double, i As Integer, j As Integer


' Here you want to set the mean and stddev
' to whichever cell contains your inputs

    mu = 0.000238095
    sd = 0.008819171
    
    Randomize
    
    For j = 1 To 10
        For i = 1 To 30
            mcSim(i, j) = mu + sd * WorksheetFunction.Norm_S_Inv(Rnd)
        Next i
    Next j

    Range("I6").Resize(30, 10) = mcSim


End Sub

Dim i As Integer

For i = 3 To 26
If Cells(i, 2) >= 0.5 Then
Cells(i, 3).Value = "Upper"
Cells(i, 3).Font.Bold = True
End If
Next i

End Sub

Sub cumulate()

Dim i As Integer

Range("D3").Value = Range("B3").Value

For i = 4 To 26
Cells(i, 4) = Cells(i - 1, 4) + Cells(i, 2)
Next i

End Sub

Sub populaterange()

Dim myrange As range

Set myrange = range("C2:J12")
myrange.Value = "=rand()"

range("C14").Value = "Average"
range("D14").Formula = WorksheetFunction.Average(myrange)

range("C15").Value = "Sum"
range("D15").Formula = WorksheetFunction.Sum(myrange)

End Sub

Sub rangething()

Dim myrange As range

Set myrange = range("B5:H10")
myrange.Value = "=rand()"

End Sub

Action Totals (Dynamic) = CALCULATETABLE(SUMMARIZE('All Audit Actions','All Audit Actions'[Topic]),'All Audit Actions'[Topic]<>BLANK())

Status - Action Revised = SWITCH(
    TRUE(),
    '2 Audits - Combined'[event status]="Complete" && '3 Actions - Combined - Audits'[# Days Completed Overdue]<=1, "Overdue",
    "Other"
)

= Table.combine({#"Replaced Value",'#"Import - VenSafe - Quality Events"})

= Table.TransformColumns(#"Changed Type", {{"Audit Url", each Text.Insert(_, 0, “https://app.solv.com.au/#/app/safety/eventdashboard/”), type text}})

import tabula
df = tabula.read_pdf(r'C:\Users\igrod\Downloads\tabela nieruchomosci.pdf', pages='all')
tabula.convert_into(r'C:\Users\igrod\Downloads\tabela nieruchomosci.pdf', r'C:\Users\igrod\Downloads\tabela nieruchomosci.csv', output_format="csv", pages='all')

Private Sub MergeProjectNameColumns()
' I had two columns, A & B. I wanted to move B over only if A was blank. See below. It is based on a selection Range, which you could use to offset the first row, perhaps.
    Dim rngRowCount As Integer
    Dim i As Integer

    'Loop through column C and simply copy the text over to B if it is not blank
    rngRowCount = Range(DataRange).Rows.Count
    ActiveCell.Offset(0, 0).Select
    ActiveCell.Offset(0, 2).Select
    For i = 1 To rngRowCount
        If (Len(RTrim(ActiveCell.Value)) > 0) Then
            Dim currentValue As String
            currentValue = ActiveCell.Value
            ActiveCell.Offset(0, -1) = currentValue
        End If
        ActiveCell.Offset(1, 0).Select
    Next i

    'Now delete the unused column
    Columns("C").Select

    Selection.Delete Shift:=xlToLeft
End Sub

Sub MakeOneColumn_Transpose()


    Dim vaCells As Variant
    Dim vOutput() As Variant
    Dim i As Long, j As Long
    Dim lRow As Long

    If TypeName(Selection) = "Range" Then
        If Selection.Count > 1 Then
            If Selection.Count <= Selection.Parent.Rows.Count Then
                vaCells = Selection.Value

                ReDim vOutput(1 To UBound(vaCells, 1) * UBound(vaCells, 2), 1 To 1)

                For j = LBound(vaCells, 2) To UBound(vaCells, 2)
                    For i = LBound(vaCells, 1) To UBound(vaCells, 1)
                        If Len(vaCells(i, j)) > 0 Then
                            lRow = lRow + 1
                            vOutput(lRow, 1) = vaCells(i, j)
                        End If
                    Next i
                Next j

                Selection.ClearContents
                Selection.Cells(1).Resize(lRow).Value = vOutput
            End If
        End If
    End If

End Sub

Sub ConditionalHighlightCells()

'Select a range of cells, then use the following code to highlight cells that contain a specified string

 

Set rngMine = Selection

For Each c In rngMine

     'highlight the cell containing "error"
    If InStr(1, c.Value, "error", vbTextCompare) Then 'I use InStr here (contains), but you can use c.value="error" for an exact match
        With c.Interior
            .Color = 65535 'yellow
            'Another format that can be used
            '.Color = RGB(200, 200, 255) ' RGB is Red, Green, Blue
            .Pattern = xlSolid
        End With
    End If
Next c

 

 End Sub

Public Sub Sheet_Select(Sheet_Name As String, Dest As String, Del_Sheet As Boolean)
' This checks that a sheet exists and then switches to it positioning into the specified column and in the first empty cell.
    Dim flag As Boolean
    Dim ws As Worksheet
    
    Application.DisplayAlerts = False
    flag = "False"
    For Each ws In ActiveWorkbook.Sheets
        If ws.Name = Sheet_Name Then
            If Del_Sheet Then
                Sheets(Sheet_Name).Delete
            Else
                flag = "True"
            End If
        End If
    Next ws
    If Not flag Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = Sheet_Name
    Sheets(Sheet_Name).Select
    Cells(Rows.Count, Dest).End(xlUp).Offset(Abs(Cells(Rows.Count, Dest).End(xlUp).Value <> ""), 0).Select
    Application.DisplayAlerts = True
End Sub

Sub FilterSelectedValues()
' This last one is used for filtering multiple values in a table. You paste the values you want to filter right below your table, then run the macro.
    Dim arrayEn() As Variant
    Dim selCol As Integer
    Dim rCell As Range
    Dim i As Long

    ReDim arrayEn(1 To 1, 1 To Selection.Count)
    selCol = Selection.Column
    i = 1

    For Each rCell In Selection
       arrayEn(1, i) = CStr(rCell.Value2)
       i = i + 1
    Next rCell

    ActiveSheet.Range("A1").AutoFilter field:=selCol, Criteria1:=arrayEn, Operator:=xlFilterValues
End Sub

Sub ToggleR1C1() 'Toggles cell referencing style:
'http://blog.contextures.com/archives/2009/12/04/excel-vba-switch-column-headings-to-numbers/
   If Application.ReferenceStyle = xlA1 Then
        Application.ReferenceStyle = xlR1C1
    Else
        Application.ReferenceStyle = xlA1
    End If
End Sub

Sub SelectionToUniqueValuesInNewWB() 'To get unique values from one column into new workbook:
    Selection.Copy
    Workbooks.Add
    Range("A1").PasteSpecial xlPasteValues
    Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

Public Sub RecalculateSelection()
' I work with a lot of really large workbooks and worksheets and one of my very favorite easy macros is this one. I generally always have to have manual calculations on and sometimes larger worksheets are still slow. This macro allows you to refresh only selected cells.

    If TypeName(Selection) = "Range" Then Selection.Calculate
End Sub

Sub Insert_Lines() ' Insert Custom Number of blank rows
Dim HowManyRows As Long
HowManyRows = InputBox("How many Rows?")
    For i = 1 To HowManyRows
        Selection.Insert Shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
    Next i
End Sub

Sub Insert_Lines10() 'Insert 10 blank lines
    For i = 1 To 10
        Selection.Insert Shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
    Next i
End Sub

Sub toggle_case_shortcut() 'Ctrl+Shift+C 'Toggle Text Case
'IS UPPER CASE - convert to lower case"
If ActiveCell.Value = UCase(ActiveCell) Then
Dim rngRectangle As Range, rngRows As Range, rngcolumns As Range
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),lower(" & rngRectangle.Address & ")))")
Cells.Find What:="", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False
'is lower case - convert to Proper Case"
ElseIf ActiveCell.Value = LCase(ActiveCell) Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Selection.Replace What:="-", Replacement:=" - ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="'", Replacement:=" ' ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="`", Replacement:=" ' ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:="  ' t", Replacement:=" 't", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),trim(" & rngRectangle.Address & ")))")
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),proper(" & rngRectangle.Address & ")))")
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Ii"",REPLACE(@,LEN(@)-2,3,"" II""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,4)="" Iii"",REPLACE(@,LEN(@)-2,4,"" III""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Iv"",REPLACE(@,LEN(@)-2,3,"" IV""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Vi"",REPLACE(@,LEN(@)-2,3,"" VI""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,4)="" Vii"",REPLACE(@,LEN(@)-2,4,"" VII""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,5)="" Viii"",REPLACE(@,LEN(@)-2,5,"" VIII""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Ix"",REPLACE(@,LEN(@)-2,3,"" IX""),@)", "@", Selection.Address))
rngRectangle = Evaluate(Replace("IF(RIGHT(@,3)="" Mp"",REPLACE(@,LEN(@)-2,3,"" MP""),@)", "@", Selection.Address))
Selection.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows
For Each c In Selection
If UCase(Left(c, 2)) = "MC" And Mid(c, 3, 1) <> "" Then
c.Value = Application.Proper(Left(c, 2)) & Application.Proper(Mid(c, 3, Len(c) - 2))
End If
Next c
Selection.Replace What:=" - ", Replacement:="-", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:=" ' ", Replacement:="'", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="1St", Replacement:="1st", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="2Nd", Replacement:="2nd", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="3Rd", Replacement:="3rd", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="4Th", Replacement:="4th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="5Th", Replacement:="5th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="6Th", Replacement:="6th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="7Th", Replacement:="7th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="8Th", Replacement:="8th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="9Th", Replacement:="9th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="10Th", Replacement:="10th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="11Th", Replacement:="11th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="12Th", Replacement:="12th", LookAt:=xlPart, MatchCase:=True
Selection.Replace What:="13Th", Replacement:="13th", LookAt:=xlPart, MatchCase:=True
If Left(cel, 1) <> "0" Then
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),clean(" & rngRectangle.Address & ")))")
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),trim(" & rngRectangle.Address & ")))")
End If
Application.DisplayAlerts = True
Cells.Find What:="", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False
'IS Proper Case - convert to UPPER CASE"
Else
Set rngRectangle = Selection
Set rngRows = rngRectangle.Resize(, 1)
Set rngcolumns = rngRectangle.Resize(1)
rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "),if(column(" & rngcolumns.Address & "),upper(" & rngRectangle.Address & ")))")
Cells.Find What:="", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False
End If
End Sub

Sub TidyEmailAddress() '(Ctrl+Shift+E)'Tidy's up email addresses
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'
Selection.ClearFormats
Selection.Hyperlinks.Delete
Selection.Replace What:="mailto:", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:="] ", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:=">", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Selection.Replace What:=Chr(160), Replacement:=" ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
'remove email "name" from before email address
For Each c In Selection
c.Value = LCase(c)
start_pos = 0
On Error Resume Next
start_pos = Application.WorksheetFunction.Search("<", c)
If start_pos <> 0 Then
c.Value = Right(c, Len(c) - start_pos)
End If
Next c
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Cells.Find What:="", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False
End Sub

Sub FillToRight() '(Ctrl+Shift+R)
'declare variables
TotalCols = ActiveCell.CurrentRegion.Columns.Count
CurrentCol = ActiveCell.Column
ColsToFill = TotalCols - CurrentCol
'declare starting cell and ending cell
cellSource = ActiveCell.Address
cellTarget = Cells(ActiveCell.Row, ActiveCell.Column + ColsToFill).Address
'check that activecell is not blank
If ActiveCell.Value = "" Then
GoTo skip_fill_1
End If
'check for completed cells in other columns of active row
CompletedCells = Application.WorksheetFunction.CountA(Range(cellSource, cellTarget))
If CompletedCells <> 1 Then
GoTo skip_fill_2
End If
'fill to right
On Error GoTo skip_fill_3
Selection.AutoFill Destination:=Range("" & cellSource & ":" & cellTarget & ""), Type:=xlFillDefault
Range("" & cellSource & ":" & cellTarget & "").Select
Exit Sub
'error traps
skip_fill_1:
MsgBox "Unable to fill right - active cell is blank", vbCritical, "ERROR"
Exit Sub
skip_fill_2:
MsgBox "Unable to fill right - other data exists on this row", vbCritical, "ERROR"
Exit Sub
skip_fill_3:
MsgBox "Unable to fill right - unspecified error", vbCritical, "ERROR"
Exit Sub
End Sub

Sub TrimText()

  Dim c As Range
  Dim AppCalcMode As XlCalculation

  Application.ScreenUpdating = False
  AppCalcMode = Application.Calculation
  Application.Calculation = xlCalculationManual

  For Each c In Selection.Cells
    c.Value2 = Trim(c.Value2)
  Next c
  
  Application.Calculation = AppCalcMode
  Application.ScreenUpdating = True
  
End Sub

Sub ConverToText()

    Dim c As Range
    Dim AppCalcMode As XlCalculation

    Application.ScreenUpdating = False
    AppCalcMode = Application.Calculation
    Application.Calculation = xlCalculationManual

    For Each c In Selection.Cells
        c.Value2 = Chr(39) & c.Value2
    Next c

    Application.Calculation = AppCalcMode
    Application.ScreenUpdating = True

End Sub

Sub swapTableReferences(formulaRange As Range)
'Switches table references in cells in range based on first table reference in each cell, ie:
    'If first table reference in a cell is relative, references are changed to fixed
    'If first table reference in a cell is fixed, references are changed to relative
    
    Dim c As Range
    Dim fText As String
    Dim tempText As String
    Dim colName As String
    Dim startStr As String
    Dim startBracket As Long
    Dim endBracket As Long
    Dim screenUp As Boolean
    
    screenUp = Application.ScreenUpdating
    
    If screenUp Then
        Application.ScreenUpdating = False
    End If
    
    For Each c In formulaRange
        fText = c.Formula
        tempText = ""
        goAhead = False
        If Mid(fText, InStr(fText, "]") + 1, 1) = ":" Then
            invert = True
        Else
            invert = False
        End If
        Do Until goAhead = True
            startBracket = InStr(fText, "[")
            endBracket = InStr(fText, "]")
            If startBracket = 0 Or endBracket = 0 Or endBracket < startBracket Then
                tempText = tempText & fText
                goAhead = True
            ElseIf Mid(fText, startBracket + 1, 1) = "[" Or Mid(fText, endBracket + 1, 1) = ":" Then
                If invert = False Or Mid(fText, startBracket + 2, 1) = "#" Then
                    endBracket = InStr(endBracket + 1, fText, "]")
                    tempText = tempText & Left(fText, endBracket + 1)
                    fText = Right(fText, Len(fText) - endBracket - 1)
                Else
                    If Mid(fText, endBracket + 1, 1) = ":" Then
                        colName = Mid(fText, startBracket + 3, endBracket - startBracket - 3)
                        tempText = tempText & Left(fText, startBracket - 1) & "[@[" & colName & "]]"
                    Else
                        colName = Mid(fText, startBracket + 2, endBracket - startBracket - 2)
                        tempText = tempText & Left(fText, startBracket - 1) & "[" & colName & "]"
                    End If
                    fText = Right(fText, Len(fText) - InStr(endBracket + 1, fText, "]") - 1)
                End If
            ElseIf invert = False Then
                If Mid(fText, startBracket + 1, 1) = "@" Then
                    If Mid(fText, startBracket + 2, 1) = "[" Then
                        endBracket = endBracket + 1
                        colName = Mid(fText, startBracket + 3, endBracket - startBracket - 4)
                    Else
                        colName = Mid(fText, startBracket + 2, endBracket - startBracket - 2)
                    End If
                    startStr = "[@["
                Else
                    colName = Mid(fText, startBracket + 1, endBracket - startBracket - 1)
                    startStr = "[["
                End If
                tempText = tempText & Left(fText, startBracket - 1) & startStr & colName & "]:[" & colName & "]]"
                fText = Right(fText, Len(fText) - endBracket)
            ElseIf (Mid(fText, startBracket + 1, 1) = "@") And (Mid(fText, startBracket + 2, 1) = "[") Then
                If Mid(fText, endBracket + 1, 1) = "]" Then
                    tempText = tempText & Left(fText, endBracket + 1)
                    fText = Right(fText, Len(fText) - endBracket - 1)
                Else
                    colName = Mid(fText, startBracket + 3, endBracket - startBracket - 3)
                    tempText = tempText & Left(fText, startBracket - 1) & "[@[" & colName & "]]"
                    fText = Right(fText, Len(fText) - InStr(endBracket + 1, fText, "]") - 1)
                End If
            Else
                tempText = tempText & Left(fText, endBracket)
                fText = Right(fText, Len(fText) - endBracket)
            End If
        Loop
        If Not tempText = fText Then
            c.Formula = tempText
        End If
    Next
    
    If screenUp Then
        Application.ScreenUpdating = True
    End If
        
End Sub

Sub swapSelectedTableReferences()
'Version to map to hotkey for working with selections
    Call swapTableReferences(ActiveSheet.Range(Selection.Address))
End Sub

Sub ConvertTextToNumber()

' A converter to change all numbers stored as text in to numbers in one go.

    Dim c As Range

    'IF YOU HAVE A SELECTION, THEN CONVERT ONLY THE SELECTION
    If Selection.Count > 1 Then
        
        For Each c In Selection
            If IsNumeric(c) And c <> "" Then c.Value = Val(c.Value)
        Next
    
    Else
    'IF NO SELECTION IS MADE, THEN CONVERT EVERY CELL WITHIN THE USED RANGE
        For Each c In ActiveSheet.UsedRange
            If IsNumeric(c) And c <> "" Then c.Value = Val(c.Value)
        Next
    
    
    End If


End Sub

Sub KillStyles()

' Style Killer. Deletes all custom styles that get randomly added into workbooks. It stops the file getting bloated with 200+ styles, preventing you from copying and pasting information later.

    Dim styT As Style

    'CONFIRMATION THAT YOU WANT TO DELETE STYLES
    If MsgBox("There are: " & ActiveWorkbook.Styles.Count - 47 & " custom styles." & vbNewLine & vbNewLine & _
    "Delete?", vbInformation + vbYesNo) <> vbYes Then Exit Sub
    
    'STATUS BAR UPDATE SO YOU KNOW WHAT'S HAPENNING AND HOW LONG ITS BEEN
    Application.StatusBar = "Deleting styles: Started: " & Time
    
    'ONE SECOND GAP GIVING YOU TIME TO BREAK IF NECESSARY
    Application.Wait Now + (#12:00:01 AM#)
    
    For Each styT In ActiveWorkbook.Styles
    
        If Not styT.BuiltIn Then styT.Delete
    
    Next styT

    'CLEAR STATUS BAR
    Application.StatusBar = False
    
End Sub

' Also bolds the top row, scrolls to the top left corner of the sheet, and autofits columns (with a maximum width so some text columns don’t get ridiculous).
' Active sheet: Prep for quick viewing
' Scroll to top-left corner, freeze top row, bold top row, AutoFit columns
Sub SetUp_NiceView()
    
    ' Declare variables
    Dim rowLast         As Long
    Dim colLast         As Integer
    Dim i               As Integer
    
    ' Maximum column width when AutoFitting columns
    ' Value needs to be in points (you can see the points when clicking-and-dragging to resize a column)
    Const maxColWidth   As Double = 35.86 ' 256 pixels
    
    ' Set up nice view!
    With ActiveSheet
        ' Unhide all cells
         On Error Resume Next
        .ShowAllData
        .Cells.EntireRow.Hidden = False
        .Cells.EntireColumn.Hidden = False
        On Error GoTo 0
        
        ' Get last row and column
        ' Excel's Find function remembers the last settings used: Search rows second so the Find function remembers to search by row
        On Error Resume Next
        colLast = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        rowLast = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        On Error GoTo 0
        
        ' If you don't want the code to unhide all cells, use these definitions instead:
        ' colLast = .UsedRange.Columns.Count
        ' rowLast = .UsedRange.Rows.Count
        
        If rowLast = 0 Or colLast = 0 Then Exit Sub
        
        ' Bold top row
        .Range(.Cells(1, 1), .Cells(1, colLast)).Font.Bold = True
        
        ' Freeze top row
        ActiveWindow.FreezePanes = False
        Application.GoTo .Cells(2, 1), True
        ActiveWindow.ScrollRow = 1
        ActiveWindow.FreezePanes = True
        .Cells(1, 1).Select
        
        ' Disable AutoFilter if it's on
        .AutoFilterMode = False
        
        ' AutoFilter top row
        With .Range(.Cells(1, 1), .Cells(rowLast, colLast))
            .AutoFilter
            
            ' AutoFit columns
            .Columns.AutoFit
            
            ' Loop through each column
            ' If any have exceed the max width, try AutoFitting just the header
            ' If the column still exceeds the max width, set it to the max width
            For i = 1 To colLast
                If .Columns(i).ColumnWidth > maxColWidth Then
                    .Columns(i).Cells(1).Columns.AutoFit
                    
                    If .Columns(i).ColumnWidth > maxColWidth Then
                        .Columns(i).ColumnWidth = maxColWidth
                    End If
                End If
            Next i
        End With
    End With
    
End Sub

Private Sub Worksheet_Change(ByVal Target As Range) 'Filter Data From Drop Down List Selection In Two Worksheets With VBA Code. If your drop down list cell in Sheet1, and the filtered data in Sheet2, when choosing one item from the drop down list, another sheet will be filtered out.
'Updateby Extendoffice
'Note: In the above code: A2 is the cell which contains the drop down list, and Sheet2 is the worksheet contains the data you want to filter. The number 1 in the script: AutoFilter 1 is the column number that you want to filter based on. You can change them to your need.
' 2. From now on, when you select one item from the drop down list in Sheet1, and the corresponding data will be filtered out in Sheet2, see screenshot:
    On Error Resume Next
    If Not Intersect(Range("A2"), Target) Is Nothing Then
        Application.EnableEvents = False
        If Range("A2").Value = "" Then
            Worksheets("Sheet2").ShowAllData
        Else
            Worksheets("Sheet2").Range("A2").AutoFilter 1, Range("A2").Value
        End If
        Application.EnableEvents = True
    End If
End Sub

Sub combinationFilter() 'Filtering based on selected combination
    Dim cell As Range, tableObj As ListObject, subSelection As Range
    Dim filterCriteria() As String, filterFields() As Integer
    Dim i As Integer
    
    'If the selection is in a table and one row height
        
    If Not Selection.ListObject Is Nothing And Selection.Rows.Count = 1 Then
        Set tableObj = ActiveSheet.ListObjects(Selection.ListObject.Name)
        
        i = 1
        ReDim filterCriteria(1 To Selection.Cells.Count) As String
        ReDim filterFields(1 To Selection.Cells.Count) As Integer
        
        ' handle multi-selects
        
        For Each subSelection In Selection.Areas
            For Each cell In subSelection
                filterCriteria(i) = cell.Text
                filterFields(i) = cell.Column - tableObj.Range.Cells(1, 1).Column + 1
                i = i + 1
            Next cell
        Next subSelection
        
        With tableObj.Range
            For i = 1 To UBound(filterCriteria)
                .AutoFilter field:=filterFields(i), Criteria1:=filterCriteria(i)
            Next i
        End With
        Set tableObj = Nothing
    End If
End Sub

Sub NormalizeData() ' Not very good, perhaps look to replace
Dim Rng As Range
Dim ws As Worksheet
 
On Error Resume Next
Set Rng = Application.InputBox(Prompt:="Select a range to normalize data" _
, Title:="Select a range", Default:=ActiveCell.Address, Type:=8)
On Error GoTo 0
 
If Rng Is Nothing Then
Else
    Application.ScreenUpdating = False
    Set ws = Sheets.Add
    i = 0
    For r = 1 To Rng.Rows.Count - 1
        For c = 1 To Rng.Columns.Count - 1
            ws.Range("A1").Offset(i, 0) = Rng.Offset(0, c).Value
            ws.Range("A1").Offset(i, 1) = Rng.Offset(r, 0).Value
            ws.Range("A1").Offset(i, 2) = Rng.Offset(r, c).Value
            i = i + 1
        Next c
    Next r
    ws.Range("A:C").EntireColumn.AutoFit
    Application.ScreenUpdating = True
End If
End Sub

Sub DeleteAllPictures() 'Deletes all pictures in a workbook (say from a converted document) in the active document

ActiveSheet.Pictures.Delete

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
'These need to be added into the worksheet VBA section itself
'Enter a price in column B and a formula is instantly entered in column C.
' Formula in column c: Cell value in column B multiplied by 1.1

Dim lRow As Single
Dim AStr As String
Dim Value As Variant
If Not Intersect(Target, Range("B:B")) Is Nothing Then
    For Each Value In Target
        If Value <> "" Then
            Range("C" & Value.Row).Formula = "=" & Target.Address & "*1.1"
        End If
    Next Value
End If
End Sub

Private Sub Worksheet_ChangeTimestamp(ByVal Target As Range)
'These need to be added into the worksheet VBA section itself
'Enter a name in column A and current date and time is entered automatically in column B. You can also copy a cell range and paste in column A. Empty cells are not processed.
Dim Value As Variant
If Not Intersect(Target, Range("A:A")) Is Nothing Then
    For Each Value In Target
        If Value <> "" Then
            Range("B" & Value.Row).Value = Now
        End If
    Next Value
End If
End Sub

Sub CopyNonContiguousSelections() 'How to copy non contiguous cell ranges
Set cellranges = Application.Selection 'Sets the Selected Cell as the cell range
Set ThisRng = Application.InputBox("Select a destination cell", "Where to paste slections?", Type:=8)
For Each cellrange In cellranges.Areas
    cellrange.Copy ThisRng.Offset(i)
    i = i + cellrange.Rows.CountLarge
Next cellrange
End Sub

'https://www.get-digital-help.com/2018/05/29/how-to-copy-non-contiguous-cell-ranges/

Sub FillColBlanks_Offset()
'by Rick Rothstein  2009-10-24
'fill blank cells in column with value above
'http://www.contextures.com/xlDataEntry02.html

  Dim Area As Range, LastRow As Long
  On Error Resume Next
  LastRow = Cells.Find(What:="*", SearchOrder:=xlRows, _
               SearchDirection:=xlPrevious, _
               LookIn:=xlFormulas).Row
  For Each Area In ActiveCell.EntireColumn(1).Resize(LastRow). _
               SpecialCells(xlCellTypeBlanks).Areas
    Area.Value = Area(1).Offset(-1).Value
  Next
End Sub

Sub Extracthyperlinks()
'Updateby Extendoffice
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "Extract URL"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
For Each Rng In WorkRng
    If Rng.Hyperlinks.Count > 0 Then
        Rng.Value = Rng.Hyperlinks.Item(1).Address
    End If
Next
End Sub

Sub RemoveLineBreaks() 'If you Just want ALL line Breaks gone use this. This removes carridgeway returns from selection
    Application.ScreenUpdating = False
    Dim rngCel As Range
    Dim strOldVal As String
    Dim strNewVal As String

    For Each rngCel In Selection
        If rngCel.HasFormula = False Then
            strOldVal = rngCel.Value
            strNewVal = strOldVal
            Debug.Print rngCel.Address

            Do

            strNewVal = Replace(strNewVal, vbLf, " ") ' replace new lines with blank space, can change to other items

            If strNewVal = strOldVal Then Exit Do
                strOldVal = strNewVal
            Loop

            If rngCel.Value <> strNewVal Then
                rngCel = strNewVal
            End If
        End If
        rngCel.Value = Application.Trim(rngCel.Value)
    Next rngCel
    Application.ScreenUpdating = True
End Sub

Sub ClearANDSetNewFormat_WordWrap_Top_Alignment()
'
' Macro1 Macro
'

'
    Selection.ClearFormats 'clears the formats from the selection
    With Selection 'sets new format
        .HorizontalAlignment = xlGeneral ' sets horizontal alignment to default
        .VerticalAlignment = xlTop 'sets verticle alignment to top
        .WrapText = True 'Sets wordwrap to on
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub

Sub Trim_Cells_Array_Method()

Dim arrData() As Variant
Dim arrReturnData() As Variant
Dim Rng As Excel.Range
Dim lRows As Long
Dim lCols As Long
Dim i As Long, j As Long

  lRows = Selection.Rows.Count
  lCols = Selection.Columns.Count

  ReDim arrData(1 To lRows, 1 To lCols)
  ReDim arrReturnData(1 To lRows, 1 To lCols)

  Set Rng = Selection
  arrData = Rng.Value

  For j = 1 To lCols
    For i = 1 To lRows
      arrReturnData(i, j) = Trim(arrData(i, j))
    Next i
  Next j

  Rng.Value = arrReturnData

  Set Rng = Nothing
End Sub

Sub ConverttoSentanceCase() 'Macro to Change All Text in a Cell Range to Initial Capital Letters
   
 Dim Rng As Range
   ' Loop to cycle through each cell in the specified range.
   For Each Rng In Selection.Cells
      ' There is not a Proper function in Visual Basic for Applications.
      ' So, you must use the worksheet function in the following form:
      Rng.Value = Application.Proper(Rng.Value) 'rng is the Dim Value - I.e. if see x.value can replace x with rng which is Dim Value
   Next
End Sub

Sub ConvertToLowercaseText() 'Converts Uppercase to lowercase text in cell selection. Macro to Change All Text in a Range to Lowercase Letters
    Dim Rng As Range
    For Each Rng In Selection.Cells 'sets range as selection
        If Rng.HasFormula = False Then
             'Use this line for UpperCase text; change UCase to LCase for LowerCase text.
            Rng.Value = LCase(Rng.Value)
        End If
    Next Rng
End Sub

Sub ConvertToUppercaseText() 'Converts lower case to upper case in cell selection. Macro to Change All Text in a Range to Uppercase Letters
    Dim Rng As Range
    For Each Rng In Selection.Cells
        If Rng.HasFormula = False Then
             'Use this line for UpperCase text; change UCase to LCase for LowerCase text.
            Rng.Value = UCase(Rng.Value)
        End If
    Next Rng
End Sub

Option Explicit
     Dim strText As String
     Dim preString As String
     Dim postString As String
     Dim uCount As String
     Dim lCount As String
     Dim B As Integer
     Dim i As Integer
     Dim char2 As String

Sub Main() ' Click to run script. Script Standardises Text in a column. I.e. USA Armed Forces becomes USA Armed Forces, BarRy JONES becomes Barry Jones
     Dim strText As String
     Dim cRow As Integer 'Current row
     cRow = 2
     Sheets("Main").Select 'Select the Sheet
     Range("A2").Select

     Do While ActiveCell > ""
         strText = ActiveCell
         strText = fProper(strText)
         Cells(cRow, 2) = strText
         cRow = cRow + 1
         Cells(cRow, 1).Select
     Loop
 
End Sub


Function fProper(strTxt As String)
     strText = strTxt
     uCount = 0
     lCount = 0
 
     'Seek the first space.
     B = InStr(1, strText, " ")
 
     'Test if there IS a space
     If B > 0 Then
         preString = Left(strText, B - 1)
         postString = Mid(strText, B, (Len(strText) - B) + 1)
 
         'Cycle through the post-string;
         'at least 1 lower case character will imply that the caps lock wasn't on
         For i = 1 To Len(postString)
             Select Case Asc(Mid(postString, i, 1))
                 Case 65 To 90
                     uCount = uCount + 1
                 Case 97 To 122
                     lCount = lCount + 1
                 Case Else
            End Select
            If lCount > 0 Then Exit For 'Go no further if a lowercase character is found
        Next i
 
        If lCount > 0 Then
            postString = StrConv(postString, 3) '3=proper case, 2=lowercase, 1=upper case
 
            'If the 2nd character of the pre-string is uppercase, it is reasonable
            'to assume the entire pre-string should be too.
            char2 = Mid(preString, 2, 1)
            If Asc(char2) >= 65 And Asc(char2) <= 90 Then
                preString = StrConv(preString, 1) 'entire pre-string is upper
            Else
                preString = StrConv(preString, 3) 'pre-string is proper
            End If
        Else
            preString = StrConv(preString, 3) 'No lower case found, Caps Lock stuck;
            postString = StrConv(postString, 3) 'Reduce the entire string to proper
        End If
        fProper = preString & postString 'Add the two elements together
     Else
 
         'No space was found, a reasonable assumption as to case can't be made;.
         'pass the string back unaltered.
         fProper = strText
     End If
End Function

Sub InsertARow() 'Inserting Multiple Rows Between Existing Rows of Data
Dim j As Long
Dim r As Range
j = InputBox("Enter the number of rows to be inserted")
Set r = Range("A2") 'set range
Do While r.Value <> ""
    Set r = r.Offset(1, 0)
    For i = 1 To j
        r.EntireRow.Insert
    Next
Loop

End Sub

Sub InsertRowsAtIntervals() ' Inserts X number of rows at X number of intervals per message dialog
'Updateby20150707
Dim Rng As Range
Dim xInterval As Integer
Dim xRows As Integer
Dim xRowsCount As Integer
Dim xNum1 As Integer
Dim xNum2 As Integer
Dim WorkRng As Range
Dim xWs As Worksheet
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
xRowsCount = WorkRng.Rows.Count
xInterval = Application.InputBox("Enter row interval. ", xTitleId, 1, Type:=1)
xRows = Application.InputBox("How many rows to insert at each interval? ", xTitleId, 1, Type:=1)
xNum1 = WorkRng.Row + xInterval
xNum2 = xRows + xInterval
Set xWs = WorkRng.Parent
For i = 1 To Int(xRowsCount / xInterval)
    xWs.Range(xWs.Cells(xNum1, WorkRng.Column), xWs.Cells(xNum1 + xRows - 1, WorkRng.Column)).Select
    Application.Selection.EntireRow.Insert
    xNum1 = xNum1 + xNum2
Next
End Sub

Sub AddBlankRows_RangeSelectedbyUser() 'How to automatically insert a blank row after a group of data based on column selected by the User - i.e. active cell
'
Dim iRow As Integer, iCol As Integer
Dim oRng As Range

Set oRng = Application.Selection 'Sets range (in this case the column) as the user selected range - I.e. this is what application.selection does

iRow = oRng.Row
iCol = oRng.Column

Do
'
If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then
    Cells(iRow + 1, iCol).EntireRow.Insert Shift:=xlDown
    iRow = iRow + 2
Else
    iRow = iRow + 1
End If
'
Loop While Not Cells(iRow, iCol).Text = ""
'
End Sub

Sub AddBlankRows_ColumnSelectedbyUser() 'How to automatically insert a blank row after a group of data based on column selected by the User - i.e. active cell
'The Cells(row,column) command allows you to stipulate which cell a range to to extend from "MyRow = ActiveCell.Row", "MyCol = ActiveCell.Column". Both these commands allow the program to identify what row or column the mouse is on
Dim iRow As Integer, iCol As Integer
Dim oRng As Range

Set oRng = Cells(1, ActiveCell.Column) 'Selects first cell e.g. "A1" in selected column to enable the function to perform task) ' Column to review for group of data

iRow = oRng.Row
iCol = oRng.Column

Do
'
If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then
    Cells(iRow + 1, iCol).EntireRow.Insert Shift:=xlDown
    iRow = iRow + 2
Else
    iRow = iRow + 1
End If
'
Loop While Not Cells(iRow, iCol).Text = ""
'
End Sub

Sub AddBlankRows_ColumnA() 'How to automatically insert a blank row after a group of data
'
Dim iRow As Integer, iCol As Integer
Dim oRng As Range

Set oRng = Range("D1") ' Column to review for group of data

iRow = oRng.Row
iCol = oRng.Column

Do
'
If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then
    Cells(iRow + 1, iCol).EntireRow.Insert Shift:=xlDown
    iRow = iRow + 2
Else
    iRow = iRow + 1
End If
'
Loop While Not Cells(iRow, iCol).Text = ""
'
End Sub

Sub FolderCreator()

    Dim objRow As Range, objCell As Range, strFolders As String, rootFolder As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        ' show the file picker dialog box
        If .Show <> 0 Then
            rootFolder = .SelectedItems(1)
              End If
    End With

    For Each objRow In ActiveSheet.UsedRange.Rows
        strFolders = rootFolder
        For Each objCell In objRow.Cells
            strFolders = strFolders & "\" & objCell
        Next
        Shell ("cmd /c md " & Chr(34) & strFolders & Chr(34))
    Next

End Sub

Sub GetColourHex()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim str0 As String, str As String
Dim cel As Range
For Each cel In Selection
str0 = Right("000000" & Hex(cel.Interior.Color), 6)
str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
cel = "#" & str & ""
Next cel
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

'Example use of the iColor function to get the background color of selected cells
Sub Get_Background_Color_Selection_Cells()
    Dim Rng As Range

    For Each Rng In Selection.Cells
        Rng.Offset(0, 1).Value = iColor(Rng, "HEX")
        Rng.Offset(0, 2).Value = iColor(Rng, "RGB")
    Next
End Sub

Public Function iColor(Rng As Range, Optional formatType As String) As Variant ' Linked with Get_Background_Colour_selection_cells Function Below
'formatType: Hex for #RRGGBB, RGB for (R, G, B) and IDX for VBA Color Index
    Dim colorVal As Variant
    colorVal = Rng.DisplayFormat.Interior.Color
    Select Case UCase(formatType)
        Case "HEX"
            iColor = "#" & Hex(colorVal Mod 256) & Hex((colorVal \ 256) Mod 256) & Hex((colorVal \ 65536))
        Case "RGB"
            iColor = (colorVal Mod 256) & ", " & ((colorVal \ 256) Mod 256) & ", " & (colorVal \ 65536)
        Case "IDX"
            iColor = Rng.Interior.ColorIndex
        Case Else
            iColor = colorVal
    End Select
End Function

Sub GetRGBColor_Font()
'PURPOSE: Output the RGB color code for the ActiveCell's Font Color
'SOURCE: www.TheSpreadsheetGuru.com

Dim HEXcolor As String
Dim RGBcolor As String

HEXcolor = Right("000000" & Hex(ActiveCell.Font.Color), 6)

RGBcolor = "RGB (" & CInt("&H" & Right(HEXcolor, 2)) & _
", " & CInt("&H" & Mid(HEXcolor, 3, 2)) & _
", " & CInt("&H" & Left(HEXcolor, 2)) & ")"

MsgBox RGBcolor, vbInformation, "Cell " & ActiveCell.Address(False, False) & ":  Font Color"

End Sub

Sub GetRGBColor_Fill()
'PURPOSE: Output the RGB color code for the ActiveCell's Fill Color
'SOURCE: www.TheSpreadsheetGuru.com

Dim HEXcolor As String
Dim RGBcolor As String

HEXcolor = Right("000000" & Hex(ActiveCell.Interior.Color), 6)

RGBcolor = "RGB (" & CInt("&H" & Right(HEXcolor, 2)) & _
", " & CInt("&H" & Mid(HEXcolor, 3, 2)) & _
", " & CInt("&H" & Left(HEXcolor, 2)) & ")"

MsgBox RGBcolor, vbInformation, "Cell " & ActiveCell.Address(False, False) & ":  Fill Color"

End Sub

Sub AddorChangeCellValueBasedOnCellColor() ' Fill in cells based on defined cell colour
    Dim rg As Range
    Dim xRg As Range
    Set xRg = Selection.Cells
    Application.DisplayAlerts = False
    For Each rg In xRg
        With rg
            Select Case .Interior.Color
                Case Is = RGB(255, 0, 0) 'Red
                    .Value = "Remove" 'Can simply replace with number
                Case Is = RGB(146, 208, 80) 'Light Green
                    .Value = "Add" 'Can also replace the Add simply replace with number no quotation marks
            End Select
        End With
    Next
    Application.DisplayAlerts = False
End Sub

= Table.AddColumn(#"Removed Columns2", "The Auditor", each if [Lead Auditor] <> "" then [Lead Auditor] else if [Internal Auditor] <> "" then [Internal Auditor] else if [External Auditor Name] <> "" then [External Auditor Name] else "Unknown")

# Actions - Status All (fix) = SWITCH(
    TRUE(),
    '2 Non-conformances - Combined'[# Actions - Assigned]="Assigned" && '2 Non-conformances - Combined'[# Actions - Not Complete (outcome works, source data needs correction)]=0, "Completed",
    '2 Non-conformances - Combined'[# Actions - Assigned]="Assigned" && '2 Non-conformances - Combined'[# Actions - Not Complete (outcome works, source data needs correction)]>=1, "Not Completed",
    '2 Non-conformances - Combined'[# Actions - Assigned]="Not Assigned", "Pending",
    "Other"
)

Table =
FILTER (
    UNION (
        SELECTCOLUMNS ( Tab1, "NewColor", [Color] ),
        SELECTCOLUMNS ( Tab2, "NewColor", [Color] )
    ),
    [NewColor] = "Red"
)

3 Actions - Combined - Audits = UNION (
    SELECTCOLUMNS (
        'VenSafe - Actions',
        "ID", 'VenSafe - Actions'[ID],
        "Action", 'VenSafe - Actions'[Action],
        "Due Date", 'VenSafe - Actions'[Due Date],
        "DaysUntilDue", 'VenSafe - Actions'[DaysUntilDue],
        "OwnerName", 'VenSafe - Actions'[OwnerName],
        "ModuleId", 'VenSafe - Actions'[ModuleId],
        "ModulePrefix", 'VenSafe - Actions'[ModulePrefix],
        "Type", 'VenSafe - Actions'[Type],
        "ActionID", 'VenSafe - Actions'[ActionID],
        "Status", 'VenSafe - Actions'[Status],
        "CreatedByName", 'VenSafe - Actions'[CreatedByName],
        "CreatedDate", 'VenSafe - Actions'[CreatedDate],
        "UpdatedByName", 'VenSafe - Actions'[UpdatedByName],
        "Completed", 'VenSafe - Actions'[Completed],
        "CompletedByName", 'VenSafe - Actions'[CompletedByName],
        "FullDescription", 'VenSafe - Actions'[FullDescription],
        "UpdatedDate", 'VenSafe - Actions'[UpdatedDate],
        "CompletedDate", 'VenSafe - Actions'[CompletedDate],
        "Source","VenSafe"
    ),
    SELECTCOLUMNS (
        'BEAMS - All Actions',
        "ID", 'BEAMS - All Actions'[ID],
        "Action", 'BEAMS - All Actions'[Action],
        "Due Date", 'BEAMS - All Actions'[Date Due],
        "DaysUntilDue", "", 
        "OwnerName", 'BEAMS - All Actions'[Owner],
        "ModuleId", "", 
        "ModulePrefix", "", 
        "Type", 'BEAMS - All Actions'[Topic], 
        "ActionID", 'BEAMS - All Actions'[Action ID], 
        "Status", 'BEAMS - All Actions'[Status], 
        "CreatedByName", 'BEAMS - All Actions'[Assigned by], 
        "CreatedDate", BLANK(), 
        "UpdatedByName", "", 
        "Completed", "", 
        "CompletedByName", "", 
        "FullDescription", 'BEAMS - All Actions'[Description], 
        "UpdatedDate", "",
        "CompletedDate", 'BEAMS - All Actions'[Date Completed],
        "Source","Beams"
    )
 )

= Table.TransformColumnNames(#"Custom1", Text.Proper)

= Table.TransformColumnNames(#"Expanded Table Column1", each if Text.Contains(Text.Upper(_),"Old Text") then "New Text" & Text.Replace(Text.Upper(_),"Old Text","") else _)

Private Sub Worksheet_ChangeTimestamp(ByVal Target As Range)
'These need to be added into the worksheet VBA section itself
'Enter a name in column A and current date and time is entered automatically in column B. You can also copy a cell range and paste in column A. Empty cells are not processed.
Dim Value As Variant
If Not Intersect(Target, Range("A:A")) Is Nothing Then
    For Each Value In Target
        If Value <> "" Then
            Range("B" & Value.Row).Value = Now
        End If
    Next Value
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
'These need to be added into the worksheet VBA section itself
'Enter a price in column B and a formula is instantly entered in column C.
' Formula in column c: Cell value in column B multiplied by 1.1

Dim lRow As Single
Dim AStr As String
Dim Value As Variant
If Not Intersect(Target, Range("B:B")) Is Nothing Then
    For Each Value In Target
        If Value <> "" Then
            Range("C" & Value.Row).Formula = "=" & Target.Address & "*1.1"
        End If
    Next Value
End If
End Sub

Sub fieldcodetotext_OriginalDocument() 'Option 2 - Convert the field codes to text in the original document
Dim MyString As String, FieldShowSetting As Boolean
For Each aField In ActiveDocument.Fields
aField.Select
MyString = MyString & vbCr & Selection.Fields(1).Code.Text ' Does not keeps the formating delination in place - i.e. no "}"
Next aField
Documents.Add
ActiveDocument.Content.InsertAfter MyString
End Sub

Sub fieldcodetotext_CreateNewDocument() 'OPtion 1 - Create a new Word document to save the converted field codes:
Dim MyString As String
ActiveWindow.View.ShowFieldCodes = True
For Each aField In ActiveDocument.Fields
aField.Select
MyString = "{ " & Selection.Fields(1).Code.Text & " }" ' Keeps the formating delination in place }  - i.e. keeps "}"
Selection.Text = MyString
Next aField
ActiveWindow.View.ShowFieldCodes = False
End Sub

Sub ConvertWordsToPdfs() 'Batch Convert Word Files To PDF, opens dialog to select folder and then goes about conversions
    Dim xIndex As String
    Dim xDlg As FileDialog
    Dim xFolder As Variant
    Dim xNewName As String
    Dim xFileName As String
    Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)
    If xDlg.Show <> -1 Then Exit Sub
    xFolder = xDlg.SelectedItems(1) + "\"
    xFileName = Dir(xFolder & "*.*", vbNormal)
    While xFileName <> ""
        If ((Right(xFileName, 4)) <> ".doc" Or Right(xFileName, 4) <> ".docx") Then
            xIndex = InStr(xFileName, ".") + 1
            xNewName = Replace(xFileName, Mid(xFileName, xIndex), "pdf")
            Documents.Open FileName:=xFolder & xFileName, _
                ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
                PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
                WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
                wdOpenFormatAuto, XMLTransform:=""
            ActiveDocument.ExportAsFixedFormat OutputFileName:=xFolder & xNewName, _
                ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
                wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
                Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
                CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
                BitmapMissingFonts:=True, UseISO19005_1:=False
            ActiveDocument.Close SaveChanges:=True
        End If
        xFileName = Dir()
    Wend
End Sub

Sub ZipAllEmailsInAFolder() 

    Dim objFolder As Outlook.Folder 

    Dim objItem As Object 

    Dim objMail As Outlook.MailItem 

    Dim strSubject As String 

    Dim varTempFolder As Variant 

    Dim varZipFile As Variant 

    Dim objShell As Object 

    Dim objFileSystem As Object 

    

    'Select an Outlook Folder 

    Set objFolder = Outlook.Application.Session.PickFolder 

  

    If Not (objFolder Is Nothing) Then 

       'Create a temp folder 

       varTempFolder = "C:\Users\cnewnham\Desktop\2\" & objFolder.Name & Format(Now, "YYMMDDHHMMSS") 

       MkDir (varTempFolder) 

       varTempFolder = varTempFolder & "\" 

    

       'Save each email as msg file 

       For Each objItem In objFolder.Items 

  

           If TypeOf objItem Is MailItem Then 

              Set objMail = objItem 

              strSubject = objMail.subject 

              strSubject = Replace(strSubject, "/", " ") 

              strSubject = Replace(strSubject, "\", " ") 

              strSubject = Replace(strSubject, ":", "") 

              strSubject = Replace(strSubject, "?", " ") 

              strSubject = Replace(strSubject, Chr(34), " ") 

  

              objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG 

           End If 

       Next 

  

       'Create a new ZIP file 

       varZipFile = "C:\Users\cnewnham\Desktop\2\" & objFolder.Name & " Emails.zip" 

       Open varZipFile For Output As #1 

       Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 

       Close #1 

  

       'Add the exported msg files to the ZIP file 

       Set objShell = CreateObject("Shell.Application") 

       objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items 

 

       On Error Resume Next 

       Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count 

          Application.Wait (Now + TimeValue("0:00:01")) 

       Loop 

       On Error GoTo 0 

  

       'Delete the temp folder 

       Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

       objFileSystem.DeleteFolder Left(varTempFolder, Len(varTempFolder) - 1) 

    End If 

End Sub 

Public Sub UnzipFileInOutlook() 'Used to unzip files in an outlook message in the compose window or message received window 

    Dim objMail As Outlook.MailItem 

    Dim objAttachments As Outlook.Attachments 

    Dim objAttachment As Outlook.Attachment 

    Dim objShell As Object 

    Dim objFileSystem As Object 

    Dim strTempFolder As String 

    Dim strFilePath As String 

    Dim strFileName As String 

  

    Set objMail = Outlook.Application.ActiveInspector.CurrentItem 

    Set objAttachments = objMail.Attachments 

  

    'Save & Unzip the zip file in local drive 

    Set objShell = CreateObject("Shell.Application") 

    Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

    strTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp" & Format(Now, "yyyy-mm-dd-hh-mm-ss") 

    MkDir (strTempFolder) 

  

    For Each objAttachment In objAttachments 

        If Right(objAttachment.FileName, 3) = "zip" Then 

           strFilePath = strTempFolder & "\" & objAttachment.FileName 

           objAttachment.SaveAsFile (strFilePath) 

           objShell.NameSpace((strTempFolder)).CopyHere objShell.NameSpace((strFilePath)).Items 

        End If 

    Next 

  

    'Reattach the files extracted from the zip file 

    strFileName = Dir(strTempFolder & "\") 

  

    While Len(strFileName) > 0 

          objMail.Attachments.Add (strTempFolder & "\" & strFileName) 

          strFileName = Dir 

          objMail.Save 

    Wend 

  

    'Delete the attachments in “.zip” file extension 

    Set objAttachments = objMail.Attachments 

    For Each objAttachment In objAttachments 

        If Right(objAttachment.FileName, 3) = "zip" Then 

           objAttachment.Delete 

           objMail.Save 

        End If 

    Next 

  

    'Delete the temp folder and files 

    objFileSystem.DeleteFolder (strTempFolder) 

End Sub 

Sub ListSelectionMonth() 'Note need to create a new custom column Month before runnining this script 

    Dim aObj As Object 

    Dim oProp As Outlook.UserProperty 

    Dim sMonth 

      

    On Error Resume Next 

      

    For Each aObj In Application.ActiveExplorer.Selection 

        Set oMail = aObj 

          

        sMonth = Month(oMail.ReceivedTime) 

        Set oProp = oMail.UserProperties.Add("Month", olText, True) 

        oProp.Value = sMonth 

        oMail.Save 

          

        Err.Clear 

    Next 

      

End Sub 

Public Sub SaveMessagesAndAttachments() 

Dim objOL As Outlook.Application 

Dim objMsg As Outlook.MailItem 'Object 

Dim objAttachments As Outlook.Attachments 

Dim i As Long 

Dim lngCount As Long 

Dim StrFile As String 

Dim StrName As String 

Dim StrFolderPath As String 

Dim strPath As String 

Dim sFileType As String 

 

Dim FSO As Object 

Dim oldName 

Set FSO = CreateObject("Scripting.FileSystemObject") 

On Error Resume Next 

Set objOL = CreateObject("Outlook.Application") 

Set objMsg = objOL.ActiveExplorer.Selection.Item(1) 

StrName = objMsg.subject 

StrName = Left(StrName, 6) ' quoteID number is 6 characters. 

 

StrFolderPath = BrowseForFolder("C:\Users\cnewnham\Desktop\Output") 

StrFolderPath = StrFolderPath & "\" & StrName & "\" 

 

' create folder if doesn't exist 

If Not FSO.FolderExists(StrFolderPath) Then 

FSO.CreateFolder (StrFolderPath) 

End If 

 

' Save message as msg file type 

objMsg.SaveAs StrFolderPath & StrName & ".msg", olMSG 

 

'save any attachments 

Set objAttachments = objMsg.Attachments 

lngCount = objAttachments.Count 

 

If lngCount > 0 Then 

 

For i = lngCount To 1 Step -1 

 

StrFile = objAttachments.Item(i).FileName 

Debug.Print StrFile 

StrFile = StrFolderPath & StrFile 

objAttachments.Item(i).SaveAsFile StrFile 

 

Next i 

End If 

 

ExitSub: 

 

Set objAttachments = Nothing 

Set objMsg = Nothing 

Set objSelection = Nothing 

Set objOL = Nothing 

End Sub 

Sub ReplyWithAttachments() 'Reply with message attachments and as forward. 

    Dim oReply As Outlook.MailItem 

    Dim oItem As Object 

      

    Set oItem = GetCurrentItem() 

    If Not oItem Is Nothing Then 

        Set oReply = oItem.Reply 

        CopyAttachments oItem, oReply 

        oReply.Display 

        oItem.UnRead = False 

    End If 

      

    Set oReply = Nothing 

    Set oItem = Nothing 

End Sub 

  

Sub ReplyAllWithAttachments() 'Reply All with message attachments and as forward. 

    Dim oReply As Outlook.MailItem 

    Dim oItem As Object 

      

    Set oItem = GetCurrentItem() 

    If Not oItem Is Nothing Then 

        Set oReply = oItem.ReplyAll 

        CopyAttachments oItem, oReply 

        oReply.Display 

        oItem.UnRead = False 

    End If 

      

    Set oReply = Nothing 

    Set oItem = Nothing 

End Sub 

Function GetCurrentItem() As Object 

    Dim objApp As Outlook.Application 

          

    Set objApp = Application 

    On Error Resume Next 

    Select Case TypeName(objApp.ActiveWindow) 

        Case "Explorer" 

            Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1) 

        Case "Inspector" 

            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem 

    End Select 

      

    Set objApp = Nothing 

End Function 

  

Sub CopyAttachments(objSourceItem, objTargetItem) 

   Set FSO = CreateObject("Scripting.FileSystemObject") 

   Set fldTemp = FSO.GetSpecialFolder(2) ' TemporaryFolder 

   strPath = fldTemp.Path & "\" 

   For Each objAtt In objSourceItem.Attachments 

      StrFile = strPath & objAtt.FileName 

      objAtt.SaveAsFile StrFile 

      objTargetItem.Attachments.Add StrFile, , , objAtt.DisplayName 

      FSO.DeleteFile StrFile 

   Next 

  

   Set fldTemp = Nothing 

   Set FSO = Nothing 

End Sub 

Sub AutoHighlight_AllOccurencesOfSpecificWords(objMail As Outlook.MailItem) 

    Dim strWord As String 

    Dim strHTMLBody As String 

  

    strHTMLBody = objMail.HTMLBody 

  

    'Change the word as per your wishes 

    strWord = "Pulse" 

  

    'If find the specific word 

    If InStr(strHTMLBody, strWord) > 0 Then 

       'Highlight it in yellow color 

       strHTMLBody = Replace(strHTMLBody, strWord, "<font style=" & Chr(34) & "background-color: yellow" & Chr(34) & ">" & strWord & "</font>") 

  

       objMail.HTMLBody = strHTMLBody 

    End If 

  

    'Add more words to be highlighted as per your needs 

    strWord = "Outlook" 

  

    If InStr(strHTMLBody, strWord) > 0 Then 

       strHTMLBody = Replace(strHTMLBody, strWord, "<font style=" & Chr(34) & "background-color: yellow" & Chr(34) & ">" & strWord & "</font>") 

  

       objMail.HTMLBody = strHTMLBody 

    End If 

  

    objMail.Save 

End Sub 

 

Sub HighlightString(MyMail As Outlook.MailItem) 

Dim strID As String 

Dim objMail As Outlook.MailItem 

strID = MyMail.EntryID 

Set objMail = Application.Session.GetItemFromID(strID) 

wordToSearch = "Pulse" 

' Ineed to find a way to match keyword from this line, assigned to wordToSearch 

 

If InStr(1, objMail.HTMLBody, wordToSearch, vbTextCompare) > 0 Then 

strData = objMail.HTMLBody 

strData = Replace(strData, wordToSearch, "<FONT style=" & Chr(34) & "BACKGROUND-COLOR: yellow" & Chr(34) & ">" & wordToSearch & "</FONT>") 

objMail.HTMLBody = strData 

objMail.Save 

End If 

Set objMail = Nothing 

End Sub 

Sub ForwardMultipleEmailsAsZipAttachment() 

    Dim objSelection As Outlook.Selection 

    Dim objMail As Outlook.MailItem 

    Dim strSubject As String 

    Dim strTempFolder As String 

    Dim varTempFolder As Variant 

    Dim objShell As Object 

    Dim varZipFile As Variant 

    Dim objForward As Outlook.MailItem 

  

    Set objSelection = Application.ActiveExplorer.Selection 

  

    If Not (objSelection Is Nothing) Then 

  

       'Save selected emails to Temporary folder 

       strTempFolder = CStr(Environ("USERPROFILE")) & "\AppData\Local\Temp" 

       varTempFolder = strTempFolder & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss-") 

       MkDir (varTempFolder) 

       varTempFolder = varTempFolder & "\" 

 

       For Each objMail In objSelection 

  

           strSubject = objMail.subject 

  

           'Remove unsupported characters in the subject 

           strSubject = Replace(strSubject, "/", " ") 

           strSubject = Replace(strSubject, "\", " ") 

           strSubject = Replace(strSubject, ":", "") 

           strSubject = Replace(strSubject, "?", " ") 

           strSubject = Replace(strSubject, Chr(34), " ") 

  

           objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG 

       Next 

     

       'Create a new zip file 

       varZipFile = InputBox("Specify a name for the new zip file", "Name Zip File") 

       varZipFile = strTempFolder & "\" & varZipFile & ".zip" 

       Open varZipFile For Output As #1 

       Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 

       Close #1 

  

       'Copy all the saved emails to the new zip file 

       Set objShell = CreateObject("Shell.Application") 

       objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items 

 

       'Keep macro running until compressing is done 

       On Error Resume Next 

       Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count 

          Application.Wait (Now + TimeValue("0:00:01")) 

       Loop 

       On Error GoTo 0 

  

       Set objMail = Application.CreateItem(olMailItem) 

  

       'Add the zip attachment to a new email 

       With objMail 

            .Attachments.Add varZipFile 

            .Display 

       End With 

    End If 

End Sub 

Sub ProperCaseSubject() 

 

    Dim myMessage As Outlook.MailItem 

    Set myMessage = Outlook.ActiveInspector.CurrentItem 

 

    Dim subject As String 

 

    subject = myMessage.subject ' Problematic line 

                                ' You need to input this or capture this 

    s = StrConv(subject, vbProperCase) 

 

    myMessage.subject = s 

 

End Sub 

Option Explicit 

 

Public Sub ExportAttachments() 'Extract attachments from outlook folder accounting for duplicates 

    Dim objOL As Outlook.Application 

    Dim objMsg As Object 

    Dim objAttachments As Outlook.Attachments 

    Dim objSelection As Outlook.Selection 

    Dim i As Long, lngCount As Long 

    Dim filesRemoved As String, fName As String, StrFolder As String, saveFolder As String, savePath As String 

    Dim alterEmails As Boolean, overwrite As Boolean 

    Dim result 

     

    saveFolder = BrowseForFolder("Select the folder to save attachments to.") 

    If saveFolder = vbNullString Then Exit Sub 

     

    result = MsgBox("Do you want to remove attachments from selected file(s)? " & vbNewLine & _ 

    "(Clicking no will export attachments but leave the emails alone)", vbYesNo + vbQuestion) 

    alterEmails = (result = vbYes) 

     

    Set objOL = CreateObject("Outlook.Application") 

    Set objSelection = objOL.ActiveExplorer.Selection 

     

    For Each objMsg In objSelection 

        If objMsg.Class = olMail Then 

            Set objAttachments = objMsg.Attachments 

            lngCount = objAttachments.Count 

            If lngCount > 0 Then 

                filesRemoved = "" 

                For i = lngCount To 1 Step -1 

                    fName = objAttachments.Item(i).FileName 

                    savePath = saveFolder & "\" & fName 

                    overwrite = False 

                    While Dir(savePath) <> vbNullString And Not overwrite 

                        Dim newFName As String 

                        newFName = InputBox("The file '" & fName & _ 

                            "' already exists. Please enter a new file name, or just hit OK overwrite.", _ 

                            "Confirm File Name", fName) 

                        If newFName = vbNullString Then GoTo skipfile 

                        If newFName = fName Then overwrite = True Else fName = newFName 

                        savePath = saveFolder & "\" & fName 

                    Wend 

                     

                    objAttachments.Item(i).SaveAsFile savePath 

                     

                    If alterEmails Then 

                        filesRemoved = filesRemoved & "<br>""" & objAttachments.Item(i).FileName & """ (" & _ 

                                                                formatSize(objAttachments.Item(i).size) & ") " & _ 

                            "<a href=""" & savePath & """>[Location Saved]</a>" 

                        objAttachments.Item(i).Delete 

                    End If 

skipfile: 

                Next i 

                 

                If alterEmails Then 

                    filesRemoved = "<b>Attachments removed</b>: " & filesRemoved & "<br><br>" 

                     

                    Dim objDoc As Object 

                    Dim objInsp As Outlook.Inspector 

                    Set objInsp = objMsg.GetInspector 

                    Set objDoc = objInsp.WordEditor 

 

                    objMsg.HTMLBody = filesRemoved + objMsg.HTMLBody 

                    objMsg.Save 

                End If 

            End If 

        End If 

    Next 

     

ExitSub: 

    Set objAttachments = Nothing 

    Set objMsg = Nothing 

    Set objSelection = Nothing 

    Set objOL = Nothing 

End Sub 

 

Function formatSize(size As Long) As String 

    Dim val As Double, newVal As Double 

    Dim unit As String 

     

    val = size 

    unit = "bytes" 

     

    newVal = Round(val / 1024, 1) 

    If newVal > 0 Then 

        val = newVal 

        unit = "KB" 

    End If 

    newVal = Round(val / 1024, 1) 

    If newVal > 0 Then 

        val = newVal 

        unit = "MB" 

    End If 

    newVal = Round(val / 1024, 1) 

    If newVal > 0 Then 

        val = newVal 

        unit = "GB" 

    End If 

     

    formatSize = val & " " & unit 

End Function 

 

'Function purpose:  To Browser for a user selected folder. 

'If the "OpenAt" path is provided, open the browser at that directory 

'NOTE:  If invalid, it will open at the Desktop level 

Function BrowseForFolder(Optional Prompt As String, Optional OpenAt As Variant) As String 

    Dim ShellApp As Object 

    Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 0, OpenAt) 

 

    On Error Resume Next 

    BrowseForFolder = ShellApp.Self.Path 

    On Error GoTo 0 

    Set ShellApp = Nothing 

      

    'Check for invalid or non-entries and send to the Invalid error handler if found 

    'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename.  All others are invalid 

    Select Case Mid(BrowseForFolder, 2, 1) 

        Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid 

        Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid 

        Case Else: GoTo Invalid 

    End Select 

      

    Exit Function 

Invalid: 

     'If it was determined that the selection was invalid, set to False 

    BrowseForFolder = vbNullString 

End Function 

 

Function BrowseForFile(Optional Prompt As String, Optional OpenAt As Variant) As String 

    Dim ShellApp As Object 

    Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 16 + 16384, OpenAt) 

     

    On Error Resume Next 

    BrowseForFile = ShellApp.Self.Path 

    On Error GoTo 0 

    Set ShellApp = Nothing 

      

    'Check for invalid or non-entries and send to the Invalid error handler if found 

    'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename.  All others are invalid 

    Select Case Mid(BrowseForFolder, 2, 1) 

        Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid 

        Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid 

        Case Else: GoTo Invalid 

    End Select 

      

    Exit Function 

Invalid: 

     'If it was determined that the selection was invalid, set to False 

    BrowseForFile = vbNullString 

End Function 

 

 

Dim strAttachmentFolder As String 

 

Sub ExtractAttachmentsFromEmailsStoredinWindowsFolder() 

    Dim objShell, objWindowsFolder As Object 

  

    'Select a Windows folder 

    Set objShell = CreateObject("Shell.Application") 

    Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows Folder:", 0, "") 

  

    If Not objWindowsFolder Is Nothing Then 

       'Create a new folder for saving extracted attachments 

       strAttachmentFolder = "C:\Users\cnewnham\Downloads\attachments-" & Format(Now, "MMDDHHMMSS") & "\" 

       MkDir (strAttachmentFolder) 

       Call ProcessFolders(objWindowsFolder.Self.Path & "\") 

       MsgBox "Completed!", vbInformation + vbOKOnly 

    End If 

End Sub 

 

Sub ProcessFolders(StrFolderPath As String) 

    Dim objFileSystem As Object 

    Dim objFolder As Object 

    Dim objFiles As Object 

    Dim objFile As Object 

    Dim objItem As Object 

    Dim i As Long 

    Dim objSubfolder As Object 

 

    Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

    Set objFolder = objFileSystem.GetFolder(StrFolderPath) 

    Set objFiles = objFolder.Files 

  

    For Each objFile In objFiles 

        If objFileSystem.GetExtensionName(objFile) = "msg" Then 

           'Open the Outlook emails stored in Windows folder 

           Set objItem = Session.OpenSharedItem(objFile.Path) 

 

           If TypeName(objItem) = "MailItem" Then 

              If objItem.Attachments.Count > 0 Then 

                 'Extract attachments 

                 For i = objItem.Attachments.Count To 1 Step -1 

                     objItem.Attachments(i).SaveAsFile strAttachmentFolder & objItem.Attachments(i).FileName 

                 Next 

              End If 

           End If 

        End If 

    Next 

  

    'Process all subfolders recursively 

    If objFolder.SubFolders.Count > 0 Then 

       For Each objSubfolder In objFolder.SubFolders 

           If ((objSubfolder.Attributes And 2) = 0) And ((objSubfolder.Attributes And 4) = 0) Then 

              Call ProcessFolders(objSubfolder.Path) 

           End If 

       Next 

    End If 

End Sub 

Public Sub SaveMessagesAndAttachments() ' Export for Single Message 

Dim objOL As Outlook.Application 

Dim objMsg As Outlook.MailItem 'Object 

Dim objAttachments As Outlook.Attachments 

Dim i As Long 

Dim lngCount As Long 

Dim StrFile As String 

Dim StrName As String 

Dim StrFolderPath As String 

Dim strDeletedFiles As String 

 Dim sFileType As String 

Dim enviro As String 

enviro = CStr(Environ("USERPROFILE")) 

     

Dim FSO As Object 

Dim oldName 

     

Set FSO = CreateObject("Scripting.FileSystemObject") 

       

    On Error Resume Next 

Set objOL = CreateObject("Outlook.Application") 

Set objMsg = objOL.ActiveExplorer.Selection.Item(1) 

 StrName = StripIllegalChar(objMsg.subject) 

     

StrFolderPath = enviro & "\Documents\" & StrName & "\" 

If Not FSO.FolderExists(StrFolderPath) Then 

    FSO.CreateFolder (StrFolderPath) 

End If 

 

 objMsg.SaveAs StrFolderPath & StrName & ".htm", olHTML 

  

    Set objAttachments = objMsg.Attachments 

    lngCount = objAttachments.Count 

          

    If lngCount > 0 Then 

      

    For i = lngCount To 1 Step -1 

      

    StrFile = objAttachments.Item(i).FileName 

    Debug.Print StrFile 

    StrFile = StrFolderPath & StrFile 

    objAttachments.Item(i).SaveAsFile StrFile 

    

    Next i 

    End If 

           

ExitSub: 

  

Set objAttachments = Nothing 

Set objMsg = Nothing 

Set objSelection = Nothing 

Set objOL = Nothing 

End Sub 

 

Function StripIllegalChar(StrInput) 

    Dim RegX            As Object 

    Set RegX = CreateObject("vbscript.regexp") 

        

    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]" 

    RegX.IgnoreCase = True 

    RegX.Global = True 

        

    StripIllegalChar = RegX.Replace(StrInput, "") 

        

ExitFunction: 

    Set RegX = Nothing 

        

End Function 

Dim strAttachmentFolder As String 

 

Sub ExtractAttachmentsFromEmailsStoredinWindowsFolder() 'Does not handle duplicates this one 

    Dim objShell, objWindowsFolder As Object 

  

    'Select a Windows folder 

    Set objShell = CreateObject("Shell.Application") 

    Set objWindowsFolder = objShell.BrowseForFolder(0, "Select a Windows Folder:", 0, "") 

  

    If Not objWindowsFolder Is Nothing Then 

       'Create a new folder for saving extracted attachments 

       strAttachmentFolder = "C:\Users\cnewnham\Downloads\attachments-" & Format(Now, "MMDDHHMMSS") & "\" 

       MkDir (strAttachmentFolder) 

       Call ProcessFolders(objWindowsFolder.Self.Path & "\") 

       MsgBox "Completed!", vbInformation + vbOKOnly 

    End If 

End Sub 

 

Sub ProcessFolders(StrFolderPath As String) 

    Dim objFileSystem As Object 

    Dim objFolder As Object 

    Dim objFiles As Object 

    Dim objFile As Object 

    Dim objItem As Object 

    Dim i As Long 

    Dim objSubfolder As Object 

 

    Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

    Set objFolder = objFileSystem.GetFolder(StrFolderPath) 

    Set objFiles = objFolder.Files 

  

    For Each objFile In objFiles 

        If objFileSystem.GetExtensionName(objFile) = "msg" Then 

           'Open the Outlook emails stored in Windows folder 

           Set objItem = Session.OpenSharedItem(objFile.Path) 

 

           If TypeName(objItem) = "MailItem" Then 

              If objItem.Attachments.Count > 0 Then 

                 'Extract attachments 

                 For i = objItem.Attachments.Count To 1 Step -1 

                     objItem.Attachments(i).SaveAsFile strAttachmentFolder & objItem.Attachments(i).FileName 

                 Next 

              End If 

           End If 

        End If 

    Next 

  

    'Process all subfolders recursively 

    If objFolder.SubFolders.Count > 0 Then 

       For Each objSubfolder In objFolder.SubFolders 

           If ((objSubfolder.Attributes And 2) = 0) And ((objSubfolder.Attributes And 4) = 0) Then 

              Call ProcessFolders(objSubfolder.Path) 

           End If 

       Next 

    End If 

End Sub 

Option Explicit 

'*********************************************************************** 

'* Code based on sample code from Martin Green and adapted to my needs 

'* more on TheTechieGuy.com - Liron@TheTechieGuy.com 

'*********************************************************************** 

'*********************************************************************** 

 

Sub GetAttachments() 

On Error Resume Next 

'create the folder if it doesnt exists: 

    Dim FSO, ttxtfile, txtfile, WheretosaveFolder 

    Dim objFolders As Object 

    Set objFolders = CreateObject("WScript.Shell").SpecialFolders 

  

    'MsgBox objFolders("mydocuments") 

    ttxtfile = objFolders("mydocuments") 

     

    Set FSO = CreateObject("Scripting.FileSystemObject") 

    Set txtfile = FSO.CreateFolder(ttxtfile & "\Email Attachments") 

    ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015 

    ' ------------------------------------------------------ 

        ' Set fso = Nothing 

    ' ------------------------------------------------------ 

    WheretosaveFolder = ttxtfile & "\Email Attachments" 

     

On Error GoTo GetAttachments_err 

' Declare variables 

    Dim ns As NameSpace 

    Dim Inbox As MAPIFolder 

    Dim Item As Object 

    Dim Atmt As Attachment 

    Dim FileName As String 

    Dim i As Integer 

    Set ns = GetNamespace("MAPI") 

    'Set Inbox = ns.GetDefaultFolder(olFolderInbox) 

    ' added the option to select whic folder to export 

    Set Inbox = ns.PickFolder 

     

    'to handle if the use cancalled folder selection 

    If Inbox Is Nothing Then 

                MsgBox "You need to select a folder in order to save the attachments", vbCritical, _ 

               "Export - Not Found" 

        Exit Sub 

    End If 

 

    '''' 

     

 

    i = 0 

' Check Inbox for messages and exit of none found 

    If Inbox.Items.Count = 0 Then 

        MsgBox "There are no messages in the selected folder.", vbInformation, _ 

               "Export - Not Found" 

        Exit Sub 

    End If 

' Check each message for attachments 

    For Each Item In Inbox.Items 

' Save any attachments found 

        For Each Atmt In Item.Attachments 

        ' This path must exist! Change folder name as necessary. 

         

        ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015 

        ' ------------------------------------------------------ 

            FileName = WheretosaveFolder & "\" & FSO.GetBaseName(Atmt.FileName) & i & "." & FSO.GetExtensionName(Atmt.FileName) 

        ' ------------------------------------------------------ 

            Atmt.SaveAsFile FileName 

            i = i + 1 

         Next Atmt 

    Next Item 

' Show summary message 

    If i > 0 Then 

        MsgBox "There were " & i & " attached files." _ 

        & vbCrLf & "These have been saved to the Email Attachments folder in My Documents." _ 

        & vbCrLf & vbCrLf & "Thank you for using Liron Segev - TheTechieGuy's utility", vbInformation, "Export Complete" 

    Else 

        MsgBox "There were no attachments found in any mails.", vbInformation, "Export - Not Found" 

    End If 

    ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015 

    ' ------------------------------------------------------ 

        Set FSO = Nothing 

    ' ------------------------------------------------------ 

' Clear memory 

GetAttachments_exit: 

    Set Atmt = Nothing 

    Set Item = Nothing 

    Set ns = Nothing 

    Exit Sub 

' Handle errors 

GetAttachments_err: 

    MsgBox "An unexpected error has occurred." _ 

        & vbCrLf & "Please note and report the following information." _ 

        & vbCrLf & "Macro Name: GetAttachments" _ 

        & vbCrLf & "Error Number: " & Err.Number _ 

        & vbCrLf & "Error Description: " & Err.Description _ 

        , vbCritical, "Error!" 

    Resume GetAttachments_exit 

End Sub 

Dim xFSO As Scripting.FileSystemObject 

Sub CopyOutlookFldStructureToWinExplorer() 

    ExportAction "Copy" 

End Sub 

    

Sub ExportAction(xAction As String) 

Dim xFolder As Outlook.Folder 

Dim xFldPath As String 

xFldPath = SelectAFolder() 

If xFldPath = "" Then 

    MsgBox "You did not select a folder. Export cancelled.", vbInformation + vbOKOnly, "Kutools for Outlook" 

Else 

    Set xFSO = New Scripting.FileSystemObject 

    Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder 

    ExportOutlookFolder xFolder, xFldPath 

End If 

Set xFolder = Nothing 

Set xFSO = Nothing 

End Sub 

  

Sub ExportOutlookFolder(ByVal OutlookFolder As Outlook.Folder, xFldPath As String) 

Dim xSubFld As Outlook.Folder 

Dim xItem As Object 

Dim xPath As String 

Dim xFilePath As String 

Dim xSubject As String 

Dim xCount As Integer 

Dim xFilename As String 

On Error Resume Next 

xPath = xFldPath & "\" & OutlookFolder.Name 

'?????????,?????? 

If Dir(xPath, 16) = Empty Then MkDir xPath 

For Each xItem In OutlookFolder.Items 

    xSubject = ReplaceInvalidCharacters(xItem.subject) 

    xFilename = xSubject & ".msg" 

    xCount = 0 

    xFilePath = xPath & "\" & xFilename 

    If xFSO.FileExists(xFilePath) Then 

        xCount = xCount + 1 

        xFilename = xSubject & " (" & xCount & ").msg" 

        xFilePath = xPath & "\" & xFilename 

    End If 

    xItem.SaveAs xFilePath, olMSG 

Next 

For Each xSubFld In OutlookFolder.Folders 

    ExportOutlookFolder xSubFld, xPath 

Next 

Set OutlookFolder = Nothing 

Set xItem = Nothing 

End Sub 

  

Function SelectAFolder() As String 

Dim xSelFolder As Object 

Dim xShell As Object 

On Error Resume Next 

Set xShell = CreateObject("Shell.Application") 

Set xSelFolder = xShell.BrowseForFolder(0, "Select a folder", 0, 0) 

If Not TypeName(xSelFolder) = "Nothing" Then 

    SelectAFolder = xSelFolder.Self.Path 

End If 

Set xSelFolder = Nothing 

Set xShell = Nothing 

End Function 

    

Function ReplaceInvalidCharacters(Str As String) As String 

Dim xRegEx 

Set xRegEx = CreateObject("vbscript.regexp") 

xRegEx.Global = True 

xRegEx.IgnoreCase = False 

xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?" 

ReplaceInvalidCharacters = xRegEx.Replace(Str, "") 

End Function 

Sub ConvertSelectedMailtoTask() 

    Dim objTask As Outlook.TaskItem 

    Dim objMail As Outlook.MailItem 

     

    Set objTask = Application.CreateItem(olTaskItem) 

    Set objMail = Application.ActiveExplorer.Selection.Item(1) 

 

With objTask 

    .subject = objMail.subject 

    .StartDate = objMail.ReceivedTime 

    .Body = objMail.Body 'Add the message as an attachment 

    .Attachments.Add objMail 

    .Save 

End With 

 

    Set objTask = Nothing 

    Set objMail = Nothing 

End Sub 

Sub ZipAllEmailsInAFolder() 

    Dim objFolder As Outlook.Folder 

    Dim objItem As Object 

    Dim objMail As Outlook.MailItem 

    Dim strSubject As String 

    Dim varTempFolder As Variant 

    Dim varZipFile As Variant 

    Dim objShell As Object 

    Dim objFileSystem As Object 

    

    'Select an Outlook Folder 

    Set objFolder = Outlook.Application.Session.PickFolder 

  

    If Not (objFolder Is Nothing) Then 

       'Create a temp folder 

       varTempFolder = "C:\Temp\" & objFolder.Name & Format(Now, "YYMMDDHHMMSS") 

       MkDir (varTempFolder) 

       varTempFolder = varTempFolder & "\" 

    

       'Save each email as msg file 

       For Each objItem In objFolder.Items 

  

           If TypeOf objItem Is MailItem Then 

              Set objMail = objItem 

              strSubject = objMail.subject 

              strSubject = Replace(strSubject, "/", " ") 

              strSubject = Replace(strSubject, "\", " ") 

              strSubject = Replace(strSubject, ":", "") 

              strSubject = Replace(strSubject, "?", " ") 

              strSubject = Replace(strSubject, Chr(34), " ") 

  

              objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG 

           End If 

       Next 

  

       'Create a new ZIP file 

       varZipFile = "C:\Temp\" & objFolder.Name & " Emails.zip" 

       Open varZipFile For Output As #1 

       Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 

       Close #1 

  

       'Add the exported msg files to the ZIP file 

       Set objShell = CreateObject("Shell.Application") 

       objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items 

 

       On Error Resume Next 

       Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count 

          Application.Wait (Now + TimeValue("0:00:01")) 

       Loop 

       On Error GoTo 0 

  

       'Delete the temp folder 

       Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

       objFileSystem.DeleteFolder Left(varTempFolder, Len(varTempFolder) - 1) 

    End If 

End Sub 

 

 

 

 

 

 

Sub ZipAttachments() 

    Dim objMail As Outlook.MailItem 

    Dim objAttachments As Outlook.Attachments 

    Dim objAttachment As Outlook.Attachment 

    Dim objFileSystem As Object 

    Dim objShell As Object 

    Dim varTempFolder As Variant 

    Dim varZipFile As Variant 

  

    'Save the attachments to Temporary folder 

    Set objFileSystem = CreateObject("Scripting.FileSystemObject") 

    varTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss-") 

    MkDir (varTempFolder) 

    varTempFolder = varTempFolder & "\" 

  

    Set objMail = Outlook.Application.ActiveInspector.CurrentItem 

    Set objAttachments = objMail.Attachments 

    For Each objAttachment In objAttachments 

        objAttachment.SaveAsFile (varTempFolder & objAttachment.FileName) 

    Next 

  

    'Create a new zip file 

    varZipFile = InputBox("Specify a name for the new zip file", "Name Zip File", objMail.subject) 

    varZipFile = objFileSystem.GetSpecialFolder(2).Path & "\" & varZipFile & ".zip" 

    Open varZipFile For Output As #1 

    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) 

    Close #1 

  

    'Copy all the saved attachments to the new zip file 

     Set objShell = CreateObject("Shell.Application") 

     objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items 

 

     'Keep macro running until Compressing is done 

     On Error Resume Next 

     Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count 

        Application.Wait (Now + TimeValue("0:00:01")) 

     Loop 

     On Error GoTo 0 

  

     'Delete all the attachments 

     Set objAttachments = objMail.Attachments 

     While objAttachments.Count > 0 

           objAttachments.Item(1).Delete 

     Wend 

  

     'Add the new zip file to the current email 

     objMail.Attachments.Add varZipFile 

  

    'Prompt 

    MsgBox ("Complete!") 

End Sub 

Dim objDictionary As Object 

 

Sub CountSentMailsByMonth() 'Must enable Microsoft Excel Reference Library 

    Dim objOutlookFile As Outlook.Folder 

    Dim objFolder As Outlook.Folder 

    Dim objExcelApp As Excel.Aapplication 

    Dim objExcelWorkbook As Excel.Workbook 

    Dim objExcelWorksheet As Excel.Worksheet 

    Dim varMonths As Variant 

    Dim varItemCounts As Variant 

    Dim nLastRow As Integer 

  

    Set objDictionary = CreateObject("Scripting.Dictionary") 

    Set objInbox = Outlook.Application.Session.GetDefaultFolder(olFolderInbox) 

  

    'Get the default Outlook data file 

    Set objOutlookFile = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Parent 

  

    For Each objFolder In objOutlookFile.Folders 

        If objFolder.DefaultItemType = olMailItem Then 

           Call ProcessFolders(objFolder) 

        End If 

    Next 

 

    Set objExcelApp = CreateObject("Excel.Application") 

    objExcelApp.Visible = True 

    Set objExcelWorkbook = objExcelApp.Workbooks.Add 

    Set objExcelWorksheet = objExcelWorkbook.Sheets(1) 

  

    With objExcelWorksheet 

        .Cells(1, 1) = "Month" 

        .Cells(1, 2) = "Count" 

    End With 

  

    varMonths = objDictionary.Keys 

    varItemCounts = objDictionary.Items 

  

    For i = LBound(varMonths) To UBound(varMonths) 

        nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.Count).End(xlUp).Row + 1 

        With objExcelWorksheet 

            .Cells(nLastRow, 1) = varMonths(i) 

            .Cells(nLastRow, 2) = varItemCounts(i) 

        End With 

    Next 

  

    objExcelWorksheet.Columns("A:B").AutoFit 

End Sub 

 

Sub ProcessFolders(ByVal objCurFolder As Outlook.Folder) 

    Dim i As Long 

    Dim objMail As Outlook.MailItem 

    Dim strMonth As String 

  

    For i = objCurFolder.Items.Count To 1 Step -1 

        If objCurFolder.Items(i).Class = olMail Then 

           Set objMail = objCurFolder.Items(i) 

           'Change to your own email address 

           If objMail.SenderEmailAddress = "you@datanumen.com" Then 

              strMonth = Format(Year(objMail.SentOn) & "-" & Month(objMail.SentOn), "YYYY/MM") 

  

              If objDictionary.Exists(strMonth) Then 

                 objDictionary(strMonth) = objDictionary(strMonth) + 1 

              Else 

                 objDictionary.Add strMonth, 1 

              End If 

           End If 

       End If 

    Next 

End Sub 

Sub ZipAllEmailsInAFolder()
    Dim objFolder As Outlook.Folder
    Dim objItem As Object
    Dim objMail As Outlook.MailItem
    Dim strSubject As String
    Dim varTempFolder As Variant
    Dim varZipFile As Variant
    Dim objShell As Object
    Dim objFileSystem As Object
   
    'Select an Outlook Folder
    Set objFolder = Outlook.Application.Session.PickFolder
 
    If Not (objFolder Is Nothing) Then
       'Create a temp folder
       varTempFolder = "C:\Temp\" & objFolder.Name & Format(Now, "YYMMDDHHMMSS")
       MkDir (varTempFolder)
       varTempFolder = varTempFolder & "\"
   
       'Save each email as msg file
       For Each objItem In objFolder.Items
 
           If TypeOf objItem Is MailItem Then
              Set objMail = objItem
              strSubject = objMail.subject
              strSubject = Replace(strSubject, "/", " ")
              strSubject = Replace(strSubject, "\", " ")
              strSubject = Replace(strSubject, ":", "")
              strSubject = Replace(strSubject, "?", " ")
              strSubject = Replace(strSubject, Chr(34), " ")
 
              objMail.SaveAs varTempFolder & strSubject & ".msg", olMSG
           End If
       Next
 
       'Create a new ZIP file
       varZipFile = "C:\Temp\" & objFolder.Name & " Emails.zip"
       Open varZipFile For Output As #1
       Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
       Close #1
 
       'Add the exported msg files to the ZIP file
       Set objShell = CreateObject("Shell.Application")
       objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items

       On Error Resume Next
       Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count
          Application.Wait (Now + TimeValue("0:00:01"))
       Loop
       On Error GoTo 0
 
       'Delete the temp folder
       Set objFileSystem = CreateObject("Scripting.FileSystemObject")
       objFileSystem.DeleteFolder Left(varTempFolder, Len(varTempFolder) - 1)
    End If
End Sub






Sub ZipAttachments()
    Dim objMail As Outlook.MailItem
    Dim objAttachments As Outlook.Attachments
    Dim objAttachment As Outlook.Attachment
    Dim objFileSystem As Object
    Dim objShell As Object
    Dim varTempFolder As Variant
    Dim varZipFile As Variant
 
    'Save the attachments to Temporary folder
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    varTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss-")
    MkDir (varTempFolder)
    varTempFolder = varTempFolder & "\"
 
    Set objMail = Outlook.Application.ActiveInspector.CurrentItem
    Set objAttachments = objMail.Attachments
    For Each objAttachment In objAttachments
        objAttachment.SaveAsFile (varTempFolder & objAttachment.FileName)
    Next
 
    'Create a new zip file
    varZipFile = InputBox("Specify a name for the new zip file", "Name Zip File", objMail.subject)
    varZipFile = objFileSystem.GetSpecialFolder(2).Path & "\" & varZipFile & ".zip"
    Open varZipFile For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
 
    'Copy all the saved attachments to the new zip file
     Set objShell = CreateObject("Shell.Application")
     objShell.NameSpace(varZipFile).CopyHere objShell.NameSpace(varTempFolder).Items

     'Keep macro running until Compressing is done
     On Error Resume Next
     Do Until objShell.NameSpace(varZipFile).Items.Count = objShell.NameSpace(varTempFolder).Items.Count
        Application.Wait (Now + TimeValue("0:00:01"))
     Loop
     On Error GoTo 0
 
     'Delete all the attachments
     Set objAttachments = objMail.Attachments
     While objAttachments.Count > 0
           objAttachments.Item(1).Delete
     Wend
 
     'Add the new zip file to the current email
     objMail.Attachments.Add varZipFile
 
    'Prompt
    MsgBox ("Complete!")
End Sub

Sub display_all_chart_shapes()

    Dim sld As Slide
    Dim shp As Shape
    Dim sr As Series
    Dim chrt As Chart
    Dim counter As Integer
    counter = 1
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            Debug.Print counter & "##" & sld.Name & " " & shp.Name
        Next shp
        counter = counter + 1
    Next sld

End Sub

Function pieknosc()
    
    Dim sld As Slide
    Dim shp As Shape
    Dim sr As Series
    Dim chrt As Chart
    Dim counter As Integer
    counter = 1
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            'Debug.Print counter & "##" & sld.Name & " " & shp.Name
            '
            '
            ' KOMENTARZE
            '
            '
            If shp.Name = "TextBox 11" Then
                Debug.Print counter & "##" & sld.Name & " " & shp.Name & "left: " & shp.Left & "top: " & shp.Top & "width: " & shp.Width
                sngDefaultSlideWidth = ActivePresentation.PageSetup.SlideWidth
                sngDefaultSlideHeight = ActivePresentation.PageSetup.SlideHeight
                'shp.Left = (sngDefaultSlideWidth / 2 - shp.Width) / 2 + sngDefaultSlideWidth / 2
                'shp.Top = (sngDefaultSlideHeight / 2 - shp.Height) / 2 + 8 + sngDefaultSlideHeight / 2
                shp.Left = 10
                shp.Top = 460
                shp.Width = 720
                shp.TextEffect.FontName = "Arial"
                shp.TextEffect.FontSize = 9
            End If
            '
            '
            ' PODTYTUŁY
            '
            '
            If shp.Name = "Podtytuł 2" Then
                Debug.Print counter & "##" & sld.Name & " " & shp.Name & "left: " & shp.Left & "top: " & shp.Top & "width: " & shp.Width
                sngDefaultSlideWidth = ActivePresentation.PageSetup.SlideWidth
                sngDefaultSlideHeight = ActivePresentation.PageSetup.SlideHeight
                'shp.Left = (sngDefaultSlideWidth / 2 - shp.Width) / 2 + sngDefaultSlideWidth / 2
                'shp.Top = (sngDefaultSlideHeight / 2 - shp.Height) / 2 + 8 + sngDefaultSlideHeight / 2
                shp.Left = 10
                shp.Top = 10
                shp.Width = 900
                shp.TextEffect.FontName = "Arial"
                shp.TextEffect.FontSize = 24
            End If
            
            
            
        Next shp
        counter = counter + 1
    Next sld
End Function

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

Sub PAUSE(Period As Single)
Dim TimeNow As Single
TimeNow = Timer
Do
    DoEvents
Loop While TimeNow + Period > Timer
End Sub

Sub ClearData()

Worksheets("Clients").Rows("2:" & Rows.Count).ClearContents
Worksheets("Cases").Rows("2:" & Rows.Count).ClearContents
Worksheets("Sessions").Rows("2:" & Rows.Count).ClearContents

End Sub