Filter microsoft service from `wmic service get` command - wmic

I'm using wmic to enumerate installed services:
wmic service get
Is it possible to hide microsoft service from it?
The query returns the following fields, none of them seems to be helpful:
AcceptPause AcceptStop Caption CheckPoint CreationClassName Description DesktopInteract DisplayName ErrorControl ExitCode InstallDate Name PathName ProcessId ServiceSpecificExitCode ServiceType Started StartMode StartName State Status SystemCreationClassName SystemName TagId WaitHint

This command can did the trick :
WMIC service where "Not PathName like '%Micro%' AND Not PathName like '%Windows%'" get Name,DisplayName,PathName,State,Status
And you can do it with Powershell script too :
Refer to this answer here How to filter Microsoft Service using PowerShell?.
You can filter the Non-Microsoft services with powershell script :
$services = Get-WmiObject Win32_Service -Property Name,DisplayName,PathName | Select Name, DisplayName,PathName
$serviceList = New-Object System.Collections.ArrayList
foreach ($service in $services) {
Try {
$path = $service.Pathname.tostring().replace('"','')
$cri = ([System.Diagnostics.FileVersionInfo]::GetVersionInfo($path)).legalcopyright
if ($cri -notlike "*Microsoft*") {
$serviceList += $service
}
} catch {}
}
$serviceList
Edit : on 02/11/2019 Vbscript Version
Here is another version using vbscript in order to export the output results with Excel.
Just copy and paste this code below as Non-Microsoft-Services.vbs and execute it by double click.
Option Explicit
' Non-Microsoft-Services.vbs
Dim objExcel,strComputer,objWMIService
Dim State,colServices,x,objService,objWorksheet,objWorkbook
' Create a new and blank spreadsheet:
Set objExcel = CreateObject("Excel.Application")
Set objWorkBook = objExcel.WorkBooks.Add
objExcel.Visible = True
Set objWorksheet = objWorkbook.Worksheets(1)
objWorksheet.Name = "Services Non-Microsoft"
objWorksheet.Tab.ColorIndex = 3
' Format the cell A1 and add the text: Service Name
objExcel.Cells(1, 1).Value = "Service Name"
objExcel.Cells(1, 1).Font.Bold = TRUE
objExcel.Cells(1, 1).Interior.ColorIndex = 43
objExcel.Cells(1, 1).Font.ColorIndex = 2
' Format the cell A2 and add the text: Display Name
objExcel.Cells(1, 2).Value = "Display Name"
objExcel.Cells(1, 2).Font.Bold = TRUE
objExcel.Cells(1, 2).Interior.ColorIndex = 43
objExcel.Cells(1, 2).Font.ColorIndex = 2
'*************************************************
' Format the cell A3 and add the text: State
objExcel.Cells(1, 3).Value = "State"
objExcel.Cells(1, 3).Font.Bold = TRUE
objExcel.Cells(1, 3).Interior.ColorIndex = 43
objExcel.Cells(1, 3).Font.ColorIndex = 2
'*************************************************
' Format the cell A4 and add the text: Executable Path
objExcel.Cells(1, 4).Value = "Executable Path"
objExcel.Cells(1, 4).Font.Bold = TRUE
objExcel.Cells(1, 4).Interior.ColorIndex = 43
objExcel.Cells(1, 4).Font.ColorIndex = 2
'*************************************************
' Format the cell A5 and add the text: Description
objExcel.Cells(1, 5).Value = "Description"
objExcel.Cells(1, 5).Font.Bold = TRUE
objExcel.Cells(1, 5).Interior.ColorIndex = 43
objExcel.Cells(1, 5).Font.ColorIndex = 2
' Find the Non-Microsoft Windows services on this computer
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colServices = objWMIService.ExecQuery("Select * From Win32_Service where Not PathName like '%Micro%' AND Not PathName like '%Windows%'")
' Write each service to Excel, starting in A2
x = 1
For Each objService in colServices
x = x + 1
objExcel.Cells(x, 1) = objService.Name
objExcel.Cells(x, 2) = objService.DisplayName
objExcel.Cells(x, 3) = objService.State
objExcel.Cells(x, 4) = objService.PathName
objExcel.Cells(x, 5) = objService.Description
State = objService.Started
If State Then
Cellule x,3,"Running"
objExcel.Cells(x, 1).Font.ColorIndex = 10
objExcel.Cells(x, 2).Font.ColorIndex = 10
objExcel.Cells(x, 3).Font.ColorIndex = 10
objExcel.Cells(x, 4).Font.ColorIndex = 10
objExcel.Cells(x, 5).Font.ColorIndex = 10
ELSE
Cellule X,3,"Stopped"
objExcel.Cells(x, 1).Font.ColorIndex = 3
objExcel.Cells(x, 2).Font.ColorIndex = 3
objExcel.Cells(x, 3).Font.ColorIndex = 3
objExcel.Cells(x, 4).Font.ColorIndex = 3
objExcel.Cells(x, 5).Font.ColorIndex = 3
end if
Next
objExcel.Columns("A:A").EntireColumn.AutoFit
objExcel.Columns("B:B").EntireColumn.AutoFit
objExcel.Columns("C:C").EntireColumn.AutoFit
objExcel.Columns("D:D").EntireColumn.AutoFit
objExcel.Columns("E:E").EntireColumn.AutoFit
Dim FSO : Set FSO = CreateObject("Scripting.FileSystemObject")
Dim Network : Set Network = CreateObject("WScript.Network")
Dim Computer : Computer = Network.ComputerName
Dim xlVer,objXL
Set objXL = CreateObject("Excel.Application")
' Check Excel Version (12.0 = 2007)
xlVer = Split(objXL.Version,".")(0)
If xlVer >= "12" Then
objExcel.ActiveWorkbook.SaveAs fso.GetAbsolutePathName(".") & "\Non-Microsoft-Services_" & Computer & ".xlsx"
objExcel.DisplayAlerts = True
' 56 = Excel 97-2003
' Voir la page http://msdn.microsoft.com/en-us/library/microsoft.office.interop.excel.xlfileformat.aspx
Else
objExcel.ActiveWorkbook.SaveAs fso.GetAbsolutePathName(".") & "\Non-Microsoft-Services_" & Computer & ".xls",56
objExcel.DisplayAlerts = True
End If
'--------------------------------------------------------------------
Sub Cellule(X,NC,chaine)
objExcel.Cells(X,NC).Value = Chaine
End Sub
'--------------------------------------------------------------------
'Function to determine the current directory
Function GetPath()
Dim path
path = WScript.ScriptFullName
GetPath = Left(path, InStrRev(path, "\"))
End Function
'--------------------------------------------------------------------
Here is a screenshot what i got as result with this vbscript :

Related

Is it possible to edit the input in a UserForm in VBA?

I am creating a yard management system to keep track of open parking spots in a lot. The userform allows the user to click on a spot in the map that is open and fill out a list of information about the truck going to that spot. Right now, if I make an error in the entry I have to redo the whole form, rather than just being able to edit the information I have already entered. Is there a way to do that without having to retype everything?
Here is the code for the user form:
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdClear_Click()
ActiveCell.ClearContents
ActiveCell.Interior.Color = vbGreen
Unload Me
End Sub
Private Sub cmdUpdate_Click()
UpdateInfo.Show
Unload Me
End Sub
Private Sub CommandButton1_Click()
UpdateInfo.Show
Unload Me
End Sub
Private Sub UserForm_Initialize()
lblInfo = ActiveCell.Value
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set rngBDock = Range("BX7:CO7")
Set rngBulk = Range("BZ21:CG21")
Set rngTransT = Range("BF17:BY17")
Set rngTransT1 = Range("BG21:BY21")
Set rngTDock = Range("BL7:BW7")
Set rngEDock = Range("CP7:CT7")
Set rngNDock = Range("CU7:DC7")
Set rngFence = Range("CQ13:CV13")
Set rngNSide = Range("CW13:DB13")
Set rngGEO = Range("BG28:DD28")
Set rngNight = Range("CH21:DD21")
Set rngNewT = Range("DK31:DK65")
Set rngNewTl = Range("DI31:DI65")
Set rngOff = Range("BN40:CL40")
Set rngOffl = Range("BN42:CL42")
Set rng = Union(rngBDock, rngBulk, rngTransT, rngTransT1, rngTDock, rngEDock, rngNDock, rngFence, rngNSide, rngGEO, rngNight, rngNewT, rngNewTl, rngOff, rngOffl)
If Not Intersect(Target, rng) Is Nothing Then
CellInfo.Show
'ActiveCell.Value = cellFill
If Not IsEmpty(ActiveCell.Value) Then
Call RealTimeTracker
End If
End If
Private Sub cmdOkUpdate_Click()
Dim i As Integer, j As Integer
For i = 0 To lbxOption.ListCount - 1
If lbxOption.Selected(i) Then j = j + 1
Next i
If j = 0 Then
MsgBox "Please select an option. ", , "Warning"
Unload Me
UpdateInfo.Show
ElseIf j = 1 Then
NoFill = False
End If
strBOL = txtBOL.Value
strID = txtID.Value
details = txtDet.Value
opt = lbxOption.Value
currtime = time()
today = Format(Now(), "MM/DD/YYYY")
emp = TextBox1.Value
With ActiveCell
spot = .Offset(-1, 0)
If Len(spot) = 0 Then
spot = .Offset(1, 0)
Else
spot = spot
End If
End With
If NoFill = True Then
cellFill = ""
ElseIf NoFill = False Then
With Sheet5
.Range("A1").Value = "Time"
.Range("B1").Value = "Date"
.Range("C1").Value = "Location"
.Range("D1").Value = "Category"
.Range("E1").Value = "BOL"
.Range("f1").Value = "Trailer #"
.Range("g1").Value = "Details"
.Range("H1").Value = "EE Name"
.Range("A2").EntireRow.Insert
.Range("A2").Value = currtime
.Range("B2").Value = today
.Range("C2").Value = spot
.Range("D2").Value = opt
.Range("E2").Value = strBOL
.Range("F2").Value = strID
.Range("G2").Value = details
.Range("H2").Value = emp
.Columns("A:H").AutoFit
End With
If Not IsEmpty(opt) Then
cellFill = opt & " " & vbCrLf & "BOL (last 5 digits): " & strBOL & " " & vbCrLf & "Trailer # " & strID & " " & vbCrLf & details & "EE Name" & emp & " " & vbCrLf
ActiveCell.Value = cellFill
Call RealTimeTracker
End If
End If
Unload Me
Sheet1.Activate
End Sub

Userform VBA Select Printer before printing

I have created a userform and have become stuck on the final stage and was wondering if somebody could assist or point me in the right direction.
I have the user selecting checkboxes for the sheets they require to print, however, due to the printers being on a network I need them to select a printer so ideally would need a popup box or print preview.
Private Sub CommandButton1_Click()
'OK = MsgBox("Printing", vbExclamation + vbOKOnly, "Sucsess")
If Me.CheckBox1 = 0 And Me.CheckBox2 = 0 And Me.CheckBox3 = 0 And Me.CheckBox4 = 0 And Me.CheckBox5 = 0 And Me.CheckBox6 = 0 And Me.CheckBox7 = 0 And Me.CheckBox8 = 0 And Me.CheckBox9 = 0 And Me.CheckBox10 = 0 Then
MsgBox "You need to select at least 1 form", vbCritical + vbOKOnly, "Error"
Else
If Me.CheckBox2 = 1 And Me.ComboBox3 = Null Then
MsgBox "Please select the number of witness statements required!", vbCritical + vbOKOnly, "Witness Staements"
Else
OK = MsgBox("Printing", vbExclamation + vbOKOnly, "Sucsess")
'Print the First Page everytime
ActiveDocument.ActiveWindow.PrintOut Range:=wdPrintRangeOfPages, Item:= _
wdPrintDocumentContent, Pages:="1" & p
'Inserting Pre info Code into the form
Dim Pg1Name As Range
Set Pg1Name = ActiveDocument.Bookmarks("Pg1Name").Range
Pg1Name.Text = Me.TextBox3.Value
Dim S1Name As Range
Set S1Name = ActiveDocument.Bookmarks("S1Name").Range
S1Name.Text = Me.TextBox3.Value
Dim S5Name As Range
Set S5Name = ActiveDocument.Bookmarks("S5Name").Range
S5Name.Text = Me.TextBox3.Value
Dim S6Name As Range
Set S6Name = ActiveDocument.Bookmarks("S6Name").Range
S6Name.Text = Me.TextBox3.Value
Dim Pg1Date As Range
Set Pg1Date = ActiveDocument.Bookmarks("Pg1Date").Range
Pg1Date.Text = Me.TextBox1.Value
Dim S1Date As Range
Set S1Date = ActiveDocument.Bookmarks("S1Date").Range
S1Date.Text = Me.TextBox1.Value
Dim Pg1Time As Range
Set Pg1Time = ActiveDocument.Bookmarks("Pg1Time").Range
Pg1Time.Text = Me.TextBox2.Value
Dim S1Time As Range
Set S1Time = ActiveDocument.Bookmarks("S1Time").Range
S1Time.Text = Me.TextBox2.Value
Dim Pg1Dept As Range
Set Pg1Dept = ActiveDocument.Bookmarks("Pg1Dept").Range
Pg1Dept.Text = Me.ComboBox2.Value
Dim S5Dept As Range
Set S5Dept = ActiveDocument.Bookmarks("S5Dept").Range
S5Dept.Text = Me.ComboBox2.Value
Dim S6Dept As Range
Set S6Dept = ActiveDocument.Bookmarks("S6Dept").Range
S6Dept.Text = Me.ComboBox2.Value
Dim Pg1Site As Range
Set Pg1Site = ActiveDocument.Bookmarks("Pg1Site").Range
Pg1Site.Text = Me.ComboBox1.Value
'Print Section 1 Immediate Response
If Accident_Incident_Form_Creator.CheckBox1.Value = True Then
ActiveDocument.ActiveWindow.PrintOut Range:=wdPrintRangeOfPages, Item:=wdPrintDocumentContent, Pages:="2" & p
End If
'Print Section 2 Witness Statement
If Accident_Incident_Form_Creator.CheckBox2.Value = True Then
ActiveDocument.ActiveWindow.PrintOut Range:=wdPrintRangeOfPages, Item:=wdPrintDocumentContent, Copies:=Me.ComboBox3.Value, Pages:="3" & p
End If
'Print Section 3 Information Gathering
If Accident_Incident_Form_Creator.CheckBox3.Value = True Then
ActiveDocument.ActiveWindow.PrintOut Range:=wdPrintRangeOfPages, Item:=wdPrintDocumentContent, Pages:="4" & p
End If
'Print Section 4 First Aid
If Accident_Incident_Form_Creator.CheckBox4.Value = True Then
ActiveDocument.ActiveWindow.PrintOut Range:=wdPrintRangeOfPages, Item:=wdPrintDocumentContent, Pages:="5" & p
End If
'Print Section 5 Damage Report
If Accident_Incident_Form_Creator.CheckBox5.Value = True Then
ActiveDocument.ActiveWindow.PrintOut Range:=wdPrintRangeOfPages, Item:=wdPrintDocumentContent, Pages:="6" & p
End If
'Print Section 6 Environmental Report
If Accident_Incident_Form_Creator.CheckBox6.Value = True Then
ActiveDocument.ActiveWindow.PrintOut Range:=wdPrintRangeOfPages, Item:=wdPrintDocumentContent, Pages:="7" & p
End If
'Print Section 7 & 8 Manual Handling & MHE
If Accident_Incident_Form_Creator.CheckBox7.Value = True Then
ActiveDocument.ActiveWindow.PrintOut Range:=wdPrintRangeOfPages, Item:=wdPrintDocumentContent, Pages:="8" & p
End If
'Print Section 9 Root Cause Investigation
If Accident_Incident_Form_Creator.CheckBox8.Value = True Then
ActiveDocument.ActiveWindow.PrintOut Range:=wdPrintRangeOfPages, Item:=wdPrintDocumentContent, Pages:="9" & p
End If
'Print Section 10 Root Cause Corrective Actions
If Accident_Incident_Form_Creator.CheckBox9.Value = True Then
ActiveDocument.ActiveWindow.PrintOut Range:=wdPrintRangeOfPages, Item:=wdPrintDocumentContent, Pages:="9" & p
End If
'Print Section 11 Safety Signoff
If Accident_Incident_Form_Creator.CheckBox10.Value = True Then
ActiveDocument.ActiveWindow.PrintOut Range:=wdPrintRangeOfPages, Item:=wdPrintDocumentContent, Pages:="11" & p
End If
If OK = 1 Then
'Close and don't save
Application.DisplayAlerts = False
ActiveDocument.Close
ActiveWindow.Close
Application.DisplayAlerts = True
End If
End If
End If
End Sub

Type Miss Match Error in Excel VBA Code

I am working on a website data extractor. I have two worksheets one for input and other for output, which looks like this..
In the first sheet the cell contains the URL needed to extract data. I am trying this URL
https://www.propertyguru.com.sg/singapore-property-listing/property-for-sale?limit=30&market=residential&property_type_code%5B%5D=4S&property_type=H&freetext=Yishun
I have written this macro..
Sub extractTablesData()
Dim IE As Object, obj As Object
Dim str, e As String
Dim pgf, pgt, pg As Integer
Dim ele, Results As Object
Dim add, size, cno, price, inurl, sp, sp1 As String
Dim isheet, rts As Worksheet
Dim LastRow As Long
Dim pgno As Variant
Set IE = CreateObject("InternetExplorer.Application")
Set isheet = Worksheets("InputSheet")
Set rts = Worksheets("Results")
URL = isheet.Cells(3, 2)
RowCount = 1
rts.Range("A" & RowCount) = "Address"
rts.Range("B" & RowCount) = "Size"
rts.Range("C" & RowCount) = "Contact Number"
rts.Range("D" & RowCount) = "Price"
rts.Range("E" & RowCount) = "Url"
LastRow = rts.Cells(Rows.Count, 2).End(xlUp).Row
'RowCount = LastRow
With IE
.Visible = True
.navigate (URL)
DoEvents
Do While IE.Busy Or IE.readyState <> 4
Loop
'Application.Wait (Now + #12:00:05 AM#)
For Each Results In .document.all
Select Case Results.className
Case "title search-title"
str = Results.innerText
str1 = Split(str, " ")
str = CInt(str1(0))
End Select
If Results.className = "btn btn-main-inverted dropdown-toggle" And InStr(1, Results.Title, " page") > 2 Then
str2 = Results.Title
str1 = Split(str2, " ")
str2 = CInt(str1(0))
End If
Next
If str2 = 0 Then
pgno = CVErr(xlErrDiv0)
Else
pgno = WorksheetFunction.RoundUp(str / str2, 0)
End If
End With
IE.Quit
Set IE = Nothing
UrlS = Split(URL, "?")
Url1 = UrlS(0)
Url2 = "?" & UrlS(1)
For i = 1 To pgno
Set IE = CreateObject("InternetExplorer.Application")
URL = Url1 & "/" & i & Url2
With IE
.Visible = True
.navigate (URL)
DoEvents
Do While IE.Busy Or IE.readyState <> 4
Loop
'Application.Wait (Now + #12:00:08 AM#)
For Each ele In .document.all
Select Case ele.className
Case "listing-img-a"
inurl = ele.href
rts.Cells(LastRow + 1, 5) = inurl
Case "listing-location"
LastRow = LastRow + 1
add = ele.innerText
rts.Cells(LastRow, 1) = add
Case "lst-sizes"
sp = Split(ele.innerText, " ยท")
size = sp(0)
rts.Cells(LastRow, 2) = size
Case "pgicon pgicon-phone js-agent-phone-number" ' btn-tools" 'pgicon pgicon-phone js-agent-phone-number" 'agent-phone-number"
rts.Cells(LastRow, 3) = ele.innerText
Case "listing-price"
price = ele.innerText
rts.Cells(LastRow, 4) = price
End Select
Next
LastRow = rts.Cells(Rows.Count, 2).End(xlUp).Row
rts.Activate
rts.Range("A" & LastRow).Select
End With
IE.Quit
Set IE = Nothing
Application.Wait (Now + #12:00:04 AM#)
Next i
MsgBox "Success"
End Sub
When I run this macro I am getting the error
Type Miss Match
When I debug it highlights the code
For i = 1 To pgno
Set IE = CreateObject("InternetExplorer.Application") URL = Url1 & "/" & i & Url2
With IE .Visible = True .navigate (URL)
I have tried my best to figure it out but could not understand where the problem is. Please help me to make correction..
It is also not getting the whole records on the link. This link contains more than 200 Records as per page is 30 records.
You can rely on implicit conversion and use the following. Assuming all pages do have numbering. You might want to improve error handling. I default to page numbers = 1 if the penultimate li CSS selector fails, otherwise it attempts to get the last page number before the ">"
Refer to my prior answer to your related question which shows you how to more effiently scrape the info off the page.
Sample code to show function being used:
Option Explicit
Public Sub GetListings()
Dim IE As New InternetExplorer, pgno As Long
With IE
.Visible = True
.navigate "https://www.propertyguru.com.sg/singapore-property-listing/property-for-sale?limit=30&market=residential&property_type_code%5B%5D=4S&property_type=H&freetext=Yishun", False
While .Busy Or .readyState < 4: DoEvents: Wend
pgno = GetNumberOfPages(.document)
End With
End Sub
Public Function GetNumberOfPages(ByVal doc As HTMLDocument) As Long
On Error GoTo errhand:
GetNumberOfPages = doc.querySelector(".listing-pagination li:nth-last-child(2)").innerText
Exit Function
errhand:
If Err.Number <> 0 Then GetNumberOfPages = 1
End Function

VBA code to get Sharepoint document library Metadata details based on document name

I have below code to open sharepoint 2010 document library's specific document based on filename (library has only excelfiles) but I am unable to read the metadata of that file. I tried with Builtin and custom document properties but there is not luck.
Sub OpenSharePointFile(StrSharePointUrl As String, strDocLibrary As String, FileNameWithExt As String)
Application.ScreenUpdating = False
Dim SPWorkbook As Workbook
Dim this As Workbook
Dim sh As Shape
Application.DisplayAlerts = False
Set SPWorkbook = Workbooks.Open(StrSharePointUrl & strDocLibrary & "\" & FileNameWithExt)
Application.DisplayAlerts = True
Set this = ThisWorkbook
If SPWorkbook Is Nothing Then
MsgBox "This product is not available"
Exit Sub
Else
'Copy Metadata
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C3").Value = SPWorkbook.BuiltinDocumentProperties("Title")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C4").Value = SPWorkbook.BuiltinDocumentProperties("Business Unit")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C5").Value = SPWorkbook.BuiltinDocumentProperties("ItemNo")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C6").Value = SPWorkbook.BuiltinDocumentProperties("ECO Type")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C7").Value = SPWorkbook.BuiltinDocumentProperties("ItemDescription")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C8").Value = SPWorkbook.BuiltinDocumentProperties("Status")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("C9").Value = SPWorkbook.BuiltinDocumentProperties("CasmasUpdate")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E3").Value = SPWorkbook.BuiltinDocumentProperties("LabelData")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E4").Value = SPWorkbook.BuiltinDocumentProperties("SpqWhActive")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E5").Value = SPWorkbook.BuiltinDocumentProperties("I2of5Label")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E6").Value = SPWorkbook.BuiltinDocumentProperties("TiXHi")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E7").Value = SPWorkbook.BuiltinDocumentProperties("SpecSent")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E8").Value = SPWorkbook.BuiltinDocumentProperties("CasmasToYes")
'ThisWorkbook.Sheets(Sht_Input.Name).Range("E9").Value = SPWorkbook.BuiltinDocumentProperties("EcoOwner")
'Copy ECO Summary:
ThisWorkbook.Sheets(Sht_Input.Name).Range("B12").Value = SPWorkbook.Sheets(Sht_Input.Name).Range("B12").Value
'Copy Ref ID
ThisWorkbook.Sheets(Sht_Input.Name).Range("D14").Value = SPWorkbook.Sheets(Sht_Input.Name).Range("D14").Value
'Copy THIS ITEM
SPWorkbook.Sheets(Sht_Input.Name).Range("C14:C74" & lRow).Copy
ThisWorkbook.Sheets(Sht_Input.Name).Range("C14").PasteSpecial xlPasteValues
'Delete from this workbook if available and Copy Shape if available in Sharepoint
If ThisWorkbook.Sheets(Sht_LCEncodingInfo.Name).Shapes.Count = 2 Then
For Each sh In ThisWorkbook.Sheets(Sht_LCEncodingInfo.Name).Shapes
If sh.Name <> "Picture 1" Then
sh.Delete
End If
Next
End If
If SPWorkbook.Sheets(Sht_LCEncodingInfo.Name).Shapes.Count = 2 Then
For Each sh In SPWorkbook.Sheets(Sht_LCEncodingInfo.Name).Shapes
If sh.Name <> "Picture 1" Then
sh.Height = 150 ' 138.96 '1.93"
sh.Width = 150 ' 228.24 '3.17"
sh.Copy
Application.Goto ThisWorkbook.Sheets(Sht_LCEncodingInfo.Name).Range("F9")
ActiveSheet.Paste
End If
Next
ThisWorkbook.Sheets(Sht_LCEncodingInfo.Name).Range("G2").Select
End If
'Activate Input sheet
ThisWorkbook.Sheets(Sht_Input.Name).Activate
ThisWorkbook.Sheets(Sht_Input.Name).Range("C3").Select
Application.DisplayAlerts = False
SPWorkbook.Close
Application.DisplayAlerts = True
MsgBox "Product Details fetched."
End If
Application.ScreenUpdating = True
End Sub
Try using ActiveWorkbook.ContentTypeProperties("Your column name")
instead of SPWorkbook.BuiltinDocumentProperties("Your column name")

VBA code for inserting unique text to each of 12 cells, when cells are blank

I am new to VBA and am severely stuck! I have 12 cells that I need to add specific text to, but only if the cells are blank. I managed to find code for 1 of them which is shown below:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$D$3" Then
If Target.Value = "Insert name of project (if known)" Then
Target.Font.ColorIndex = xlAutomatic
Target.Value = ""
Exit Sub
End If
End If
If [D3].Value = "" Then
[D3].Value = "Insert name of project (if known)"
[D3].Font.ColorIndex = 1
Else
[D3].Font.ColorIndex = xlAutomatic
End If
End Sub
However, seemingly I can only use this once per sheet. I need code that is similar to this that will hopefully do the same job. The remaining 11 cells need to have unique text.
Basically what I am trying to do is prompt the user to insert details in each of these cells and once the cells are filled, the form will be complete.
Any assistance is appreciated.
Hi, Apologies for the delay. This is the final edit, which works perfectly. I thought I was going to have an issue with 'undo' (CTRL+Z) but it seems to be fine now. Thanks again.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim clls(1 To 12) As String
Dim msg(1 To 12) As String
Dim i As Long, addr As String, c As Range
clls(1) = "D3": msg(1) = "Insert name of project (if known)"
clls(2) = "D4": msg(2) = "Insert closest street address"
clls(3) = "H3": msg(3) = "Insert name of landowner (if applicable)"
clls(4) = "H4": msg(4) = "Insert name of Developer (if applicable)"
clls(5) = "H6": msg(5) = "Insert name of PM Co. (if different from above)"
clls(6) = "H7": msg(6) = "Insert name of Designer (if applicable)"
clls(7) = "H8": msg(7) = "Insert name of Constructor"
clls(8) = "L3": msg(8) = "Insert project number (if known)"
clls(9) = "L6": msg(9) = "Insert name"
clls(10) = "L7": msg(10) = "Insert submission date"
clls(11) = "D10": msg(11) = "Brief description of project: Adjustment, deviation, main upsizing, main extension, lead-in, lead-out, etc."
clls(12) = "D11": msg(12) = "Insert length of asset (number only)"
Set c = Target.Cells(1)
addr = c.Address(False, False)
For i = 1 To UBound(clls)
If addr = clls(i) Then
If c.Value = msg(i) Then
c.Font.ColorIndex = xlAutomatic
c.Value = ""
End If
Else
With Me.Range(clls(i))
If .Value = "" Then
.Value = msg(i)
.Font.ColorIndex = 1
End If
End With
End If
Next i
End Sub
Might need a bit of tweaking...
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim clls(1 To 5) As String
Dim msg(1 To 5) As String
Dim i As Long, addr As String, c As Range
clls(1) = "D3": msg(1) = "Message 1"
clls(2) = "D4": msg(2) = "Message 2"
clls(3) = "D5": msg(3) = "Message 3"
clls(4) = "D6": msg(4) = "Message 4"
clls(5) = "D7": msg(5) = "Message 5"
Set c = Target.cells(1)
addr = c.Address(False, False)
For i = 1 To UBound(clls)
If addr = clls(i) Then
If c.Value = msg(i) Then
c.Font.ColorIndex = xlAutomatic
c.Value = ""
End If
Else
With Me.Range(clls(i))
If .Value = "" Then
.Value = msg(i)
.Font.ColorIndex = 1
End If
End With
End If
Next i
End Sub