highlight cell based on value, mulptie search array - arrays

I am using VBA to find certain 2 or 3 letter "user id" numbers that live at the end of Purchase order numbers. For instance 123456DWR.
I have about 1500 different "user id" numbers (DWR's) I did not reate the code i am using, but i added 900 or so id's to the search array line.
Currently, this code highlights/colors the entire row the id number is found in. I just need this to highlight the cell it self.
I've tried to make it reference Cells, in stead of Cells.Row but it doesn't work.
Could someone steer me in the right direction? Code Below
Sub Affiliates()
'This code must be updated as affiliates are added or removed
Dim allRange As Range
Dim searchTerms As Variant
Dim cell As Range, word As Variant
Sheets("UPS").Activate
Application.ScreenUpdating = False
Application.Calculation = xlManual
searchTerms = Array("AF2-", "AF3-", "AF4-", "AF5-", "AF6-", "AFP-", "AIP-", "AKB-", "APE-", "ASP-", "AU-", "AU2-", "AU3-", "au4-", "AZ-", "B1-", "BD4-", "BDZ-", "BLS-", "BLT-", "BMK-", "BMP-", "BQ-", "BR2-", "BR3-", "BRI-", "BRT-", "BTU-", "BV-", "BX2-", "BXM-", "BZG-", "CAV-", "CJW-", "CM2-", "CSI-", "DES-", "DGR-", "DXE-", "ED2-", _
"ED3-", "ED4-", "ED5-", "ED6-", "EDA-", "EMV-", "ERR-", "ERS-", "FM2-", "FMP-", "FYI-", "GCK-", "GH-", "GL2-", "GL3-", "GLP-", "GPR-", "GSH-", "HDL-", "HMF-", "HO-", "HW2-", "HWM-", "J33-", "JC4-", "JC5-", "JCG-", "JFG-", "JG-", "JGR-", "JJM-", "JPR-", "JR4-", "JRD-", "JRW-", "JSB-", "JWW-", "KAH-", "KBP-", "KC2-", _
"KCP-", "KM2-", "KMF-", "KN2-", "KN3-", "KNC-", "KP2-", "KPB-", "KRN-", "KRT-", "LKV-", "MB-", "MJP-", "MYG-", "MZE-", "P72-", "PAC-", "PTG-", "PVT-", "RGN-", "S42-", "S44-", "S45-", "S46-", "S48-", "S52-", "S53-", "SA1-", "SA5-", "SAN-", "SD2-", "SD3-", "SD4-", "SD5-", "SD6-", "SD7-", "SD8-", "SD9-", "SHK-", "SKY-", "SMY-", "SN-", "SP-", _
"SPA-", "SQ2-", "SQX-", "SUD-", "SUE-", "SZT-", "TEL-", "TF2-", "TGT-", "THR-", "TMT-", "tpp-", "VN-", "WR-", "WX-", "WX3-", "WYS-", "YM2-", "YM3-", "YM4-", "YM5-", "YMT-", "wdd-""AAA-", "ABT-", "CM3-", "CM5-", "CMG-", "DCD-", "DR9-", "DRB-", "DRW-", "DVW-", "EE-", "EG2-", "EG3-", "EGS-", "EMD-", "EP2-", "EP3-", "EP5-", "EPS-", "EV-", "FAS-", "FL2-", "GM8-", "GM9-", "GMN-", "KR5-", "KR6-", "KR7-", "KRC-", "M33-", "M34-", "M35-", "M36-", "M37-", "M38-", "M39-", "M42-", _
"M43-", "M46-", "M47-", "M48-", "M49-", "MM2-", "MOX-", "MR3-", "MR4-", "MRV-", "MS5-", "MS6-", "MS7-", "MS8-", "MS9-", "MSY-", "MT-", "MUS-", "NM-", "P32-", "PF6-", "PFP-", "PM2-", "PM3-", "PM4-", "PM5-", "PM6-", "PM7-", "PM8-", "PM9-", "PMR-", "RS2-", "RSD-", "RST-", "S62-", "S63-", "SHE-", "SMK-", "SUN-", "SVA-", "Z1-", "Z42-", "ZA5-", "ZA6-", "ZAG-", "ZAH-", "ZDM-", _
"3P-", "AAP-", "AD3-", "AD4-", "AD9-", "ADC-", "ADV-", "AFF-", "AJT-", "ALB-", "AMA-", "AP2-", "AP3-", "APG-", "APM-", "APS-", "ARG-", "ASA-", "AVD-", "AZP-", "BAG-", "BCD-", "BCK-", "BE2-", "BE3-", "BGB-", "BJB-", "BP2-", "BPM-", "BR-", "BTC-", "BTM-", "BUZ-", "BWL-", "C22-", "C23-", "C24-", "CAR-", "CCP-", "CCW-", "CG-", "CGK-", "CLJ-", "CME-", "CP9-", "CPM-", "CPR-", "CPT-", "CPU-", "CRM-", "CRN-", "CT-", "DAV-", "DC-", "DC3-", "DC4-", "DKP-", "DNC-", "DNF-", "DNT-", "DP2-", "DPL-", "DPT-", "DQ-", "DR2-", "DRT-", "E22-", "EI-", "EP-", "FB2-", "FB3-", "FBG-", "FCA-", "FL-", "FLN-", "FNN-", "FPS-", "FVE-", "GA-", "GB2-", "GEE-", "GF2-", "GFS-", "GFY-", "GM-", "GME-", "GN-", "GU2-", "GUS-", _
"HJS-", "JAE-", "JDN-", "JHG-", "JNK-", "JTP-", "JWP-", "JX2-", "KCD-", "KK2-", "KKA-", "KW-", "L22-", "L23-", "l24-", "L9-", "LA5-", "LAX-", "LD-", "LD2-", "LR-", "M44-", "MA2-", "MA5-", "MA6-", "MAJ-", "MAL-", "MD2-", "MD3-", "MDM-", "MK1-", "MKY-", "MM-", "MN-", "MO-", "MP5-", "MPE-", "MRK-", "MTH-", _
"MV-", "MY-", "NA-", "NE2-", "NE3-", "NEP-", "NF-", "NGP-", "NIP-", "NNF-", "NSM-", "OCA-", "OD-", "P62-", "P63-", "PBB-", "PCK-", "PDM-", "PEN-", "PH-", "PHX-", "PLG-", "PMM-", "PMN-", "PNR-", "PPC-", "PPW-", "PSP-", "PST-", "PW3-", "PW5-", "QA-", "QM-", "RAD-", "RAY-", "RE-", "RGK-", "RG5-", "RKT-", "RSW-", "RU-", "RV-", "S27-", "SAM-", "SC2-", "SCG-", "SCH-", "SDC-", "SF2-", "SFL-", "SGE-", "SMA-", "STW-", "TBM-", "TFG-", "THK-", "THY-", "TOG-", "TRC-", "TW2-", "TWE-", "TY2-", "TYB-", "UC-", "UH-", "UP2-", "UP3-", "UPW-", "VB-", "WDB-", "WM-", "WTC-", "WZ-", "XS-", "YN-", "YN2-", "YN3-", "YN4-", "YN5-", "YN6-", "YN7-", "YNG-", "YP-", "YPR-", "ZA2-", "ZAA-", "ZAD-", "STT-", "ef-", "JX-", _
"A2-", "ABP-", "ABS-", "AE-", "AF-", "AJ-", "ALL-", "AM-", "AN2-", "ANS-", "AP-", "APP-", "ASJ-", "ASK-", "ASM-", "ATJ-", "BA2-", "BAA-", "BAM-", "BAS-", "BBE-", "BBP-", "BG-", "BG2-", "BGD-", "BK2-", "BK3-", "BK4-", "BK5-", "BK6-", "BK7-", "BLZ-", "BMG-", "BP-", "BSK-", "BTB-", "BX-", "BYJ-", "CEC-", "CHT-", "CJ2-", "CJR-", "CMB-", "CN-", "COB-", "CPC-", "CPP-", "CTA-", "CWG-", "D22-", "D24-", "D25-", "D26-", "D27-", "D28-", "D29-", "D30-", "D32-", "D33-", "D34-", "D35-", "DAJ-", "DAK-", "DAP-", "DB2-", "DBC-", "DBP-", "DCA-", "DDP-", "DEL-", "DGJ-", "DMJ-", "DP3-", "DPI-", "DRA-", "DS-", "DS2-", "DS3-", "DS4-", "DS5-", "DS6-", "DS7-", "DS8-", "DS9-", "DSN-", "DSP-", "DSR-", "DT2-", "DT3-", _
"DT4-", "DT5-", "DTM-", "EC2-", "ECL-", "EDM-", "ENS-", "ERN-", "ES2-", "ES3-", "es4-", "ESC-", "ESH-", "EZB-", "FDA-", "FI-", "FI2-", "GBL-", "GCR-", "GRR-", "GS-", "GT2-", "GTE-", "HM2-", "HM3-", "HM4-", "HM5-", "HMG-", "HN-", "HNN-", "IA-", "JMS-", "JSY-", "K24-", "K26-", "K27-", "KAU-", "KMK-", "KPN-", "KRK-", "LT-", "MDY-", "MKD-", "MLM-", "MMM-", "MP-", "MR2-", "MR6-", "MRA-", "MRE-", "NAA-", "PA-", "PCS-", "PK2-", "PK3-", "PK4-", "PK5-", "PKG-", "POD-", "PT4-", "PTS-", "RDV-", "RH2-", "RHS-", "RJS-", "SA-", "SBG-", "SEB-", "SJP-", "SL2-", "SLT-", "SQ-", "STC-", "STF-", "SY-", "T99-", "TRY-", "UMT-", "VP-", "VZ-", "VZ1-", "WAG-", "WDM-", "WH-", "YJ-", "STM", _
"A1-", "AMS-", "AN-", "AY2-", "AYW-", "BB-", "BDS-", "BJC-", "BNG-", "BSH-", "BW2-", "BWR-", "BWS-", "CGP-", "CM4-", "CPS-", "CQS-", "CV-", "CWN-", "CY-", "D42-", "D43-", "DPB-", "DTG-", "DTY-", "DV-", "DVD-", "DVE-", "DY2-", "ELR-", "ENX-", "EST-", "FN2-", "FN3-", "FN4-", "FNT-", "FNY-", "FS2-", "FSN-", "GBD-", "GG2-", "GGM-", "GLM-", "GM5-", "GSE-", "HCE-", "HGT-", "HNA-", "HYD-", "IB-", "IE-", "IW-", "J32-", "JBE-", "JEN-", "JLR-", "JLW-", "JN6-", "JN7-", "JN8-", "JNH-", "JV2-", "JVP-", "KA2-", "KBK-", "KNX-", "KPP-", "KPR-", "LC-", "LPE-", "LRE-", "LV2-", "LV3-", "LV4-", "LV5-", "LVL-", "M12-", "M15-", "M19-", "M24-", "M51-", "M52-", "M53-", "M55-", "M57-", "M63-", "M64-", "M68-", "M69-", "M72-", "M73-", "M74-", "M75-", "MCC-", "MCK-", "MHA-", "MJF-", "MKE-", "MMT-", "MP2-", _
"MPN-", "MPT-", "MR5-", "MST-", "MU6-", "MUN-", "NEB-", "NVT-", "NY5-", "PJ2-", "PJM-", "PNY-", "PRV-", "PTM-", "PTN-", "RCG-", "RED-", "REN-", "RH3-", "RN2-", "RND-", "RT2-", "RT3-", "RT4-", "RTC-", "SDM-", "SPP-", "SV2-", "SV3-", "SV4-", "SV5-", "SV6-", "SV7-", "SVN-", "SVS-", "SXT-", "TCB-", "TE5-", "TE6-", "TEE-", "TER-", "TK2-", "TKG-", "TNY-", "TUV-", "VPG-", "VU-", "VW2-", "VWP-", "W25-", "WO-", "WR4-", "WR5-", "WR6-", "WR8-", "WR9-", "WRH-", "WTT-", "Y23-", "YG-", "YK-", "Z22-", "Z23-", "ZAM-", "ZAQ-", "ZAR-", "ZAS-", "ZAU-", "ZFG-", "ZIN-", "ZR2-", "BA-", "BAR-", "BES-", "BLR-", "BS2-", "BSY-", "CD-", "CRT-", "CS-", "CT7-", "CTY-", "CVT-", "CWP-", "CZ-", "DRS-", "DVL-", "EM2-", "EM3-", "EM4-", "EM5-", "EMF-", "EPR-", "EVE-", "FP-", "FSP-", "FST-", "HTT-", "JA5-", "JAC-", "JAN-", "JK2-", "JKH-", _
"BNT-", "DER-", "DWH-", "EL-", "EU-", "FF-", "FM-", "FR-", "FSZ-", "GC-", "GMA-", "GMS-", "HB-", "ISM-", "JAA-", "JBS-", "JD-", "KG-", "KKP-", "KYT-", "LBG-", "LCH-", "LFM-", "LGG-", "M0-", "MBS-", "MC2-", "MCD-", "N41-", "NKS-", "NTR-", "PBD-", "PG-", "PPA-", "PQT-", "PRE-", "PT7-", "PT9-", "PTE-", "PTY-", "RSN-", "SBE-", "SCB-", "SCR-", "T32-", "T33-", "TA-", "TMA-", "TRX-", "TWN-", "UBR-", "UM2-", "UMP-", "WCA-", "XP-", "YBH-", "ZAV-", "JKM-", "JPD-", "JW-", "KA3-", "KA5-", "KAG-", "KB-", "KG4-", "KG5-", "KGP-", "KNS-", "LGW-", "LMN-", "LSG-", "LU2-", "MAE-", "MDG-", "MDN-", "MMP-", "MPM-", "MPV-", "MR-", "MRG-", "N22-", "N23-", "N25-", "N26-", "N28-", "N29-", "N35-", "N36-", "N37-", "N38-", "N39-", "NK2-", "NK3-", "NK8-", "NKD-", "PFA-", "PFU-", "PHM-", "PM-", "PMD-", "PPM-", "PRD-", "PT-", "PV2-", "PV3-", "PV4-", "PVC-", "PW6-", "PWP-", "PX-", "PXZ-", "PZ2-", "PZZ-", "RAV-", "RKY-", "RPC-", "RUF-", "RV2-", "RV3-", "SEG-", "SHM-", _
"SJM-", "SJR-", "SN2-", "SN3-", "SN4-", "SNP-", "SRC-", "T22-", "T23-", "T24-", "TKA-", "TRK-", "TSQ-", "TST-", "W3-", "W5-", "W6-", "WJM-", "WRX-", "X0-", "XM2-", "XM3-", "XM4-", "XPD-", "yd-", "ZAB-", "ZAC-", "ZAE-", "ZAN-", "ZAT-", "LU-", "WY-", "ZL-", "ABN-", "AT-", "ATH-", "AYH-", "BDD-", "BMD-", "BNB-", "BRN-", "BRY-", "BU-", "CCG-", "CFL-", "CKH-", "CXS-", "DJB-", "EAB-", "EJ-", "ETP-", "FNE-", "GB-", "GER-", "GGN-", "GHP-", "GI-", "GR2-", "GR5-", "GR6-", "GR7-", "GR8-", "GRY-", "HCR-", "HN3-", "HNT-", "JBM-", "JEM-", "JFM-", "JKR-", "JNP-", "JS2-", "JU4-", "JU5-", "JU6-", "JU7-", "JU8-", "JU9-", "JYD-", "KE-", "KE2-", "KT2-", "KT3-", "KTE-", "KY2-", "KYN-", _
"LFD-", "LLD-", "LNE-", "LX-", "ME2-", "ME3-", "MEC-", "MRN-", "MY2-", "MYM-", "NE-", "NFN-", "NMK-", "NT2-", "NT3-", "NTW-", "PD2-", "PD3-", "PD4-", "PD5-", "PDT-", "PH2-", "PHS-", "PMC-", "PP2-", "PPB-", "PSY-", "PTA-", "PW2-", "PW4-", "PWA-", "PWD-", "PWH-", "PY2-", "PY3-", "PY4-", "PYS-", "PYV-", "RDG-", "RGP-", "RKP-", "RKX-", "RPP-", "RUS-", "SC-", "SM2-", "SM5-", "SMS-", "SND-", "TEP-", "TKY-", "TUH-", "VPS-", "VST-", "VU2-", "VU3-", "VUE-", "WC-", "WC2-", "WPP-", "WRD-", "YU-")
ReDim rowsToHighlight(0) As String
Set allRange = ActiveSheet.UsedRange
For Each cell In allRange
For Each word In searchTerms
If InStr(1, cell, word, vbTextCompare) Then
rowsToHighlight(UBound(rowsToHighlight)) = CStr(cell.Row)
ReDim Preserve rowsToHighlight(UBound(rowsToHighlight) + 1)
End If
Next word
Next cell
On Error Resume Next
ReDim Preserve rowsToHighlight(UBound(rowsToHighlight) - 1)
Dim v As Long
For v = UBound(rowsToHighlight) To LBound(rowsToHighlight) Step -1
Rows(rowsToHighlight(v)).Interior.Color = vbGreen
Next
Application.ScreenUpdating = True
End Sub

It seems that your procedure can be improved further as it actually requires heavy maintenance as indicated by:
I have about 1500 different "user id" numbers (DWR's) I did not reate
the code i am using, but i added 900 or so id's to the search array
line
'This code must be updated as affiliates are added or removed
Therefore I suggest to create a table in a separated worksheet then the procedure can automatically get the array of items to search.
Also there is not need to loop thru every cell in the worksheet "UPS" and compare the contents with the items in the list, instead use the FIND function.
The code below includes all the above and additionally gives the possibility of highlighting the string found (user id).
Sub Affiliates()
Rem Use a table to keep the list of affiliates instead of "Hard Codding" it (see Set Users ID List below)
Const kCol As Byte = 3 'Indicates the column containing the User Id's List
Dim WshSrc As Worksheet, WshTrg As Worksheet
Dim aUsrIdLst As Variant, vUsrId As Variant
Dim rFound As Range, sFound1st As String
Dim bPos As Byte
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Rem Set Worksheets
Set WshSrc = ThisWorkbook.Worksheets("UserIds")
Set WshTrg = ThisWorkbook.Worksheets("UPS")
Rem Set Users ID List
With WshSrc
aUsrIdLst = .Cells(1, kCol).Resize(fLastRow_byCol(.Columns(kCol))).Value2
aUsrIdLst = WorksheetFunction.Transpose(aUsrIdLst)
End With
Rem To Clear prior formatting - Uncomment if needed
Rem watch out for prior formatting of all other cells!
Rem WshTrg.UsedRange.Style = "Normal"
With WshTrg.UsedRange
For Each vUsrId In aUsrIdLst
Set rFound = .Find( _
What:=vUsrId, After:=.Cells(1), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not (rFound Is Nothing) Then
sFound1st = rFound.Address
Do
With rFound
bPos = InStr(rFound, vUsrId)
Rem Fill Interior and String Found
.Interior.Color = vbGreen
With .Characters(Start:=bPos, Length:=Len(vUsrId)).Font
.Bold = 1
.Color = RGB(55, 86, 35)
End With: End With
Set rFound = .FindNext(rFound)
Loop While Not (rFound Is Nothing) And rFound.Address <> sFound1st
End If: Next: End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic 'update as required
End Sub
Function fLastRow_byCol(ColTrg As Range) As Long
Rem ===============================================================================
On Error Resume Next
fLastRow_byCol = ColTrg.Find(What:="*", _
After:=ColTrg.Cells(1), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
On Error GoTo 0
End Function

This is all you need in the macro (in addition to the declarations and the definition of searchTerms, but look also into conditional formatting
Set allRange = ActiveSheet.UsedRange
For Each cell In allRange
For Each word In searchTerms
If InStr(1, cell, word, vbTextCompare) Then cell.Interior.Color = vbGreen
Next word
Next cell
Application.ScreenUpdating = True
End Sub

Changed your list to a comma separated string and split it for use. Removed allRange, rowHighloght array, and other unnecessary stuff.
Make sure you exit a long check sequence like this when a match is made using Exit For. You don't need the sheet to be active to reference it. I left the .Activate at the end in case you wanted the code to send you there when it's done, but it can just as easily be removed.
Sub Affiliates()
'This code must be updated as affiliates are added or removed
Dim searchTerms As Variant
Dim cell As Range, word As Variant
Application.ScreenUpdating = False
Application.Calculation = xlManual
searchTerms = "AF2-,AF3-,AF4-,AF5-,AF6-,AFP-,AIP-,AKB-,APE-,ASP-,AU-,AU2-,AU3-,au4-,AZ-,B1-,BD4-,BDZ-,BLS-,BLT-,BMK-,BMP-,BQ-,BR2-,BR3-,BRI-,BRT-,BTU-,BV-,BX2-,BXM-,BZG-,CAV-,CJW-,CM2-,CSI-,DES-,DGR-,DXE-,ED2-," & _
"ED3-,ED4-,ED5-,ED6-,EDA-,EMV-,ERR-,ERS-,FM2-,FMP-,FYI-,GCK-,GH-,GL2-,GL3-,GLP-,GPR-,GSH-,HDL-,HMF-,HO-,HW2-,HWM-,J33-,JC4-,JC5-,JCG-,JFG-,JG-,JGR-,JJM-,JPR-,JR4-,JRD-,JRW-,JSB-,JWW-,KAH-,KBP-,KC2-," & _
"KCP-,KM2-,KMF-,KN2-,KN3-,KNC-,KP2-,KPB-,KRN-,KRT-,LKV-,MB-,MJP-,MYG-,MZE-,P72-,PAC-,PTG-,PVT-,RGN-,S42-,S44-,S45-,S46-,S48-,S52-,S53-,SA1-,SA5-,SAN-,SD2-,SD3-,SD4-,SD5-,SD6-,SD7-,SD8-,SD9-,SHK-,SKY-,SMY-,SN-,SP-," & _
"SPA-,SQ2-,SQX-,SUD-,SUE-,SZT-,TEL-,TF2-,TGT-,THR-,TMT-,tpp-,VN-,WR-,WX-,WX3-,WYS-,YM2-,YM3-,YM4-,YM5-,YMT-,wdd-,AAA-,ABT-,CM3-,CM5-,CMG-,DCD-,DR9-,DRB-,DRW-,DVW-,EE-,EG2-,EG3-,EGS-,EMD-,EP2-,EP3-,EP5-,EPS-,EV-,FAS-,FL2-,GM8-,GM9-,GMN-,KR5-,KR6-,KR7-,KRC-,M33-,M34-,M35-,M36-,M37-,M38-,M39-,M42-," & _
"M43-,M46-,M47-,M48-,M49-,MM2-,MOX-,MR3-,MR4-,MRV-,MS5-,MS6-,MS7-,MS8-,MS9-,MSY-,MT-,MUS-,NM-,P32-,PF6-,PFP-,PM2-,PM3-,PM4-,PM5-,PM6-,PM7-,PM8-,PM9-,PMR-,RS2-,RSD-,RST-,S62-,S63-,SHE-,SMK-,SUN-,SVA-,Z1-,Z42-,ZA5-,ZA6-,ZAG-,ZAH-,ZDM-," & _
"3P-,AAP-,AD3-,AD4-,AD9-,ADC-,ADV-,AFF-,AJT-,ALB-,AMA-,AP2-,AP3-,APG-,APM-,APS-,ARG-,ASA-,AVD-,AZP-,BAG-,BCD-,BCK-,BE2-,BE3-,BGB-,BJB-,BP2-,BPM-,BR-,BTC-,BTM-,BUZ-,BWL-,C22-,C23-,C24-,CAR-,CCP-,CCW-,CG-,CGK-,CLJ-,CME-,CP9-,CPM-,CPR-,CPT-,CPU-,CRM-,CRN-,CT-,DAV-,DC-,DC3-,DC4-,DKP-,DNC-,DNF-,DNT-,DP2-,DPL-,DPT-,DQ-,DR2-,DRT-,E22-,EI-,EP-,FB2-,FB3-,FBG-,FCA-,FL-,FLN-,FNN-,FPS-,FVE-,GA-,GB2-,GEE-,GF2-,GFS-,GFY-,GM-,GME-,GN-,GU2-,GUS-," & _
"HJS-,JAE-,JDN-,JHG-,JNK-,JTP-,JWP-,JX2-,KCD-,KK2-,KKA-,KW-,L22-,L23-,l24-,L9-,LA5-,LAX-,LD-,LD2-,LR-,M44-,MA2-,MA5-,MA6-,MAJ-,MAL-,MD2-,MD3-,MDM-,MK1-,MKY-,MM-,MN-,MO-,MP5-,MPE-,MRK-,MTH-," & _
"MV-,MY-,NA-,NE2-,NE3-,NEP-,NF-,NGP-,NIP-,NNF-,NSM-,OCA-,OD-,P62-,P63-,PBB-,PCK-,PDM-,PEN-,PH-,PHX-,PLG-,PMM-,PMN-,PNR-,PPC-,PPW-,PSP-,PST-,PW3-,PW5-,QA-,QM-,RAD-,RAY-,RE-,RGK-,RG5-,RKT-,RSW-,RU-,RV-,S27-,SAM-,SC2-,SCG-,SCH-,SDC-,SF2-,SFL-,SGE-,SMA-,STW-,TBM-,TFG-,THK-,THY-,TOG-,TRC-,TW2-,TWE-,TY2-,TYB-,UC-,UH-,UP2-,UP3-,UPW-,VB-,WDB-,WM-,WTC-,WZ-,XS-,YN-,YN2-,YN3-,YN4-,YN5-,YN6-,YN7-,YNG-,YP-,YPR-,ZA2-,ZAA-,ZAD-,STT-,ef-,JX-," & _
"A2-,ABP-,ABS-,AE-,AF-,AJ-,ALL-,AM-,AN2-,ANS-,AP-,APP-,ASJ-,ASK-,ASM-,ATJ-,BA2-,BAA-,BAM-,BAS-,BBE-,BBP-,BG-,BG2-,BGD-,BK2-,BK3-,BK4-,BK5-,BK6-,BK7-,BLZ-,BMG-,BP-,BSK-,BTB-,BX-,BYJ-,CEC-,CHT-,CJ2-,CJR-,CMB-,CN-,COB-,CPC-,CPP-,CTA-,CWG-,D22-,D24-,D25-,D26-,D27-,D28-,D29-,D30-,D32-,D33-,D34-,D35-,DAJ-,DAK-,DAP-,DB2-,DBC-,DBP-,DCA-,DDP-,DEL-,DGJ-,DMJ-,DP3-,DPI-,DRA-,DS-,DS2-,DS3-,DS4-,DS5-,DS6-,DS7-,DS8-,DS9-,DSN-,DSP-,DSR-,DT2-,DT3-," & _
"DT4-,DT5-,DTM-,EC2-,ECL-,EDM-,ENS-,ERN-,ES2-,ES3-,es4-,ESC-,ESH-,EZB-,FDA-,FI-,FI2-,GBL-,GCR-,GRR-,GS-,GT2-,GTE-,HM2-,HM3-,HM4-,HM5-,HMG-,HN-,HNN-,IA-,JMS-,JSY-,K24-,K26-,K27-,KAU-,KMK-,KPN-,KRK-,LT-,MDY-,MKD-,MLM-,MMM-,MP-,MR2-,MR6-,MRA-,MRE-,NAA-,PA-,PCS-,PK2-,PK3-,PK4-,PK5-,PKG-,POD-,PT4-,PTS-,RDV-,RH2-,RHS-,RJS-,SA-,SBG-,SEB-,SJP-,SL2-,SLT-,SQ-,STC-,STF-,SY-,T99-,TRY-,UMT-,VP-,VZ-,VZ1-,WAG-,WDM-,WH-,YJ-,STM," & _
"A1-,AMS-,AN-,AY2-,AYW-,BB-,BDS-,BJC-,BNG-,BSH-,BW2-,BWR-,BWS-,CGP-,CM4-,CPS-,CQS-,CV-,CWN-,CY-,D42-,D43-,DPB-,DTG-,DTY-,DV-,DVD-,DVE-,DY2-,ELR-,ENX-,EST-,FN2-,FN3-,FN4-,FNT-,FNY-,FS2-,FSN-,GBD-,GG2-,GGM-,GLM-,GM5-,GSE-,HCE-,HGT-,HNA-,HYD-,IB-,IE-,IW-,J32-,JBE-,JEN-,JLR-,JLW-,JN6-,JN7-,JN8-,JNH-,JV2-,JVP-,KA2-,KBK-,KNX-,KPP-,KPR-,LC-,LPE-,LRE-,LV2-,LV3-,LV4-,LV5-,LVL-,M12-,M15-,M19-,M24-,M51-,M52-,M53-,M55-,M57-,M63-,M64-,M68-,M69-,M72-,M73-,M74-,M75-,MCC-,MCK-,MHA-,MJF-,MKE-,MMT-,MP2-," & _
"MPN-,MPT-,MR5-,MST-,MU6-,MUN-,NEB-,NVT-,NY5-,PJ2-,PJM-,PNY-,PRV-,PTM-,PTN-,RCG-,RED-,REN-,RH3-,RN2-,RND-,RT2-,RT3-,RT4-,RTC-,SDM-,SPP-,SV2-,SV3-,SV4-,SV5-,SV6-,SV7-,SVN-,SVS-,SXT-,TCB-,TE5-,TE6-,TEE-,TER-,TK2-,TKG-,TNY-,TUV-,VPG-,VU-,VW2-,VWP-,W25-,WO-,WR4-,WR5-,WR6-,WR8-,WR9-,WRH-,WTT-,Y23-,YG-,YK-,Z22-,Z23-,ZAM-,ZAQ-,ZAR-,ZAS-,ZAU-,ZFG-,ZIN-,ZR2-,BA-,BAR-,BES-,BLR-,BS2-,BSY-,CD-,CRT-,CS-,CT7-,CTY-,CVT-,CWP-,CZ-,DRS-,DVL-,EM2-,EM3-,EM4-,EM5-,EMF-,EPR-,EVE-,FP-,FSP-,FST-,HTT-,JA5-,JAC-,JAN-,JK2-,JKH-," & _
"BNT-,DER-,DWH-,EL-,EU-,FF-,FM-,FR-,FSZ-,GC-,GMA-,GMS-,HB-,ISM-,JAA-,JBS-,JD-,KG-,KKP-,KYT-,LBG-,LCH-,LFM-,LGG-,M0-,MBS-,MC2-,MCD-,N41-,NKS-,NTR-,PBD-,PG-,PPA-,PQT-,PRE-,PT7-,PT9-,PTE-,PTY-,RSN-,SBE-,SCB-,SCR-,T32-,T33-,TA-,TMA-,TRX-,TWN-,UBR-,UM2-,UMP-,WCA-,XP-,YBH-,ZAV-,JKM-,JPD-,JW-,KA3-,KA5-,KAG-,KB-,KG4-,KG5-,KGP-,KNS-,LGW-,LMN-,LSG-,LU2-,MAE-,MDG-,MDN-,MMP-,MPM-,MPV-,MR-,MRG-,N22-,N23-,N25-,N26-,N28-,N29-,N35-,N36-,N37-,N38-,N39-,NK2-,NK3-,NK8-,NKD-,PFA-,PFU-,PHM-,PM-,PMD-,PPM-,PRD-,PT-,PV2-,PV3-,PV4-,PVC-,PW6-,PWP-,PX-,PXZ-,PZ2-,PZZ-,RAV-,RKY-,RPC-,RUF-,RV2-,RV3-,SEG-,SHM-," & _
"SJM-,SJR-,SN2-,SN3-,SN4-,SNP-,SRC-,T22-,T23-,T24-,TKA-,TRK-,TSQ-,TST-,W3-,W5-,W6-,WJM-,WRX-,X0-,XM2-,XM3-,XM4-,XPD-,yd-,ZAB-,ZAC-,ZAE-,ZAN-,ZAT-,LU-,WY-,ZL-,ABN-,AT-,ATH-,AYH-,BDD-,BMD-,BNB-,BRN-,BRY-,BU-,CCG-,CFL-,CKH-,CXS-,DJB-,EAB-,EJ-,ETP-,FNE-,GB-,GER-,GGN-,GHP-,GI-,GR2-,GR5-,GR6-,GR7-,GR8-,GRY-,HCR-,HN3-,HNT-,JBM-,JEM-,JFM-,JKR-,JNP-,JS2-,JU4-,JU5-,JU6-,JU7-,JU8-,JU9-,JYD-,KE-,KE2-,KT2-,KT3-,KTE-,KY2-,KYN-," & _
"LFD-,LLD-,LNE-,LX-,ME2-,ME3-,MEC-,MRN-,MY2-,MYM-,NE-,NFN-,NMK-,NT2-,NT3-,NTW-,PD2-,PD3-,PD4-,PD5-,PDT-,PH2-,PHS-,PMC-,PP2-,PPB-,PSY-,PTA-,PW2-,PW4-,PWA-,PWD-,PWH-,PY2-,PY3-,PY4-,PYS-,PYV-,RDG-,RGP-,RKP-,RKX-,RPP-,RUS-,SC-,SM2-,SM5-,SMS-,SND-,TEP-,TKY-,TUH-,VPS-,VST-,VU2-,VU3-,VUE-,WC-,WC2-,WPP-,WRD-,YU-"
searchTerms = Split(searchTerms, ",")
For Each cell In Sheets("UPS").UsedRange
For Each word In searchTerms
If InStr(cell, word) > 0 Then
cell.Interior.Color = vbGreen
Exit For
End If
Next word
Next cell
Application.ScreenUpdating = True
Sheets("UPS").Activate
End Sub

Related

Word VBA Array not behaving as expected

I'm iterating through a list of keywords to define terms in a document but only certain keywords will get picked up.
For instance, with Array("Agreement", "deed", "AGREEMENT", "letter agreement", "letter", "Undertaking"), "Agreement" and "letter" get picked up just fine, but letter agreement and Undertaking do not.
I've tried rearranging the order of the array but that does nothing.
I'm guessing there's something fundamental about arrays I'm misunderstanding. I'm more familiar with python and am going for list functionality.
Full code is below. Any pointers would be very much appreciated.
Function getagree() As String
Dim aggrlist As Variant
aggrlist = Array("Agreement", "NDA", "deed", "AGREEMENT", "letter
agreement", "letter", "Undertaking", "Confidentiality Undertaking",
"agreement")
Set myRange = ActiveDocument.Content
With myRange.Find
For Each aggr In aggrlist
.ClearFormatting
.Text = aggr
.MatchWholeWord = True
.MatchCase = True
.Execute Forward:=True
If .Found = True Then
getagree = aggr
End If
Next
End With
End Function
Try using an underscore (_) to break your string into multiple lines...
aggrlist = Array("Agreement", "NDA", "deed", "AGREEMENT", _
"letter agreement", "letter", "Undertaking", _
"Confidentiality Undertaking", "agreement")

How to save the names of clicked objects to a text file (Visual Basic)

I am doing a cinema booking system as my A-Level Computing project, I am using labels as seats, when they are clicked they turn green and I am trying to save the name of each clicked label to an array that will be later saved to a file. This is the procedure for when a seat is clicked:
Private Sub lblA1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles lblA1.Click, lblA2.Click, lblA3.Click, lblA4.Click, lblA5.Click, lblA6.Click, lblA7.Click, lblB1.Click, lblB2.Click, lblB3.Click, lblB4.Click, lblB5.Click, lblB6.Click, lblB7.Click, lblC1.Click, lblC2.Click, lblC3.Click, lblC4.Click, lblC5.Click, lblC6.Click, lblC7.Click, lblD1.Click, lblD2.Click, lblD3.Click, lblD4.Click, lblD5.Click, lblD6.Click, lblD7.Click, lblE1.Click, lblE2.Click, lblE3.Click, lblE4.Click, lblE5.Click, lblE6.Click, lblE7.Click, lblF1.Click, lblF2.Click, lblF3.Click, lblF4.Click, lblF5.Click, lblF6.Click, lblF7.Click, lblG1.Click, lblG2.Click, lblG3.Click, lblG4.Click, lblG5.Click, lblG6.Click, lblG7.Click, lblH1.Click, lblH2.Click, lblH3.Click, lblH4.Click, lblH5.Click, lblH6.Click, lblH7.Click, lblI1.Click, lblI2.Click, lblI3.Click, lblI4.Click, lblI5.Click, lblI6.Click, lblI7.Click, lblJ1.Click, lblJ2.Click, lblJ3.Click, lblJ4.Click, lblJ5.Click, lblJ6.Click, lblJ7.Click, lblK1.Click, lblK2.Click, lblK3.Click, lblK4.Click, lblK5.Click, lblK6.Click, lblK7.Click, lblL1.Click, lblL2.Click, lblL3.Click, lblL4.Click, lblL5.Click, lblL6.Click, lblL7.Click
ClickedBox = CType(sender, Label)
If ClickedBox.BackColor = Color.DodgerBlue Then 'Checks if seat is free
ClickedBox.BackColor = Color.LawnGreen 'Changes colour of seats clicked to green
ClickedBox.ForeColor = Color.LawnGreen
TotalNoOfSeats = TotalNoOfSeats + 1
strSeats(intCounter3) = ClickedBox.Name
intCounter3 = intCounter3 + 1
Else
MsgBox("This seat has already been booked")
End If
End Sub
When the user clicks the 'Book Seats' button I have called a procedure that attempts to save the array of seat names to a text file. The following code is the procedure:
Sub SaveSeats()
Dim intloop As Integer
FileWriter = New StreamWriter("Seats " + AddFilm.strFilms(1, intSelectedFilm) + ".txt")
FileWriter.WriteLine(intCounter3)
For intloop = 0 To intCounter3
FileWriter.WriteLine(strSeats(intloop))
Next
FileWriter.Close()
End Sub
On the line that contains:
FileWriter.WriteLine(strSeats(intloop))
I get the following error: "System.IndexOutOfRangeException was unhandled
Message=Index was outside the bounds of the array."
Any help is appreciated.
Edit: i have used this approach but now i have another problem:
The error containing: "ObjectDisposedException - Cannot write to a closed TextWriter." appears on the line:
FileWriter.WriteLine(SeatList(intloop))
This is the procedure I am using now to Save the list to the text file:
Sub SaveSeats()
Dim intloop As Integer
FileWriter = New StreamWriter("Seats " + AddFilm.strFilms(1, intSelectedFilm) + ".txt")
FileWriter.WriteLine(NoOfClickedSeats)
For intloop = 1 To NoOfClickedSeats
FileWriter.WriteLine(SeatList(intloop))
FileWriter.Close()
Next
End Sub
Array indices are zero based, so you have to subtract 1 from intCounter3:
For intloop As Int32 = 0 To intCounter3 - 1
FileWriter.WriteLine(strSeats(intloop))
Next
Consider that intCounter3 is 1 (the array contains one element). You would try to access the second element with intCounter3(1) which causes the IndexOutOfRangeException.
By the way, you should choose more meaningful names than intCounter3, otherwise it'll be soon difficult to understand your code for you or others.
Edit: another problem with code is that you are resizing the array without redim. You should use a List(Of String) instead which can be resized:
So instead of:
strSeats(intCounter3) = ClickedBox.Name
Use a list instead and it's Add method:
Private SeatList As New ist(Of String)
Private Sub lblA1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles lblA1.Click, lblA2.Click, lblA3.Click, lblA4.Click, lblA5.Click, lblA6.Click, lblA7.Click, lblB1.Click, lblB2.Click, lblB3.Click, lblB4.Click, lblB5.Click, lblB6.Click, lblB7.Click, lblC1.Click, lblC2.Click, lblC3.Click, lblC4.Click, lblC5.Click, lblC6.Click, lblC7.Click, lblD1.Click, lblD2.Click, lblD3.Click, lblD4.Click, lblD5.Click, lblD6.Click, lblD7.Click, lblE1.Click, lblE2.Click, lblE3.Click, lblE4.Click, lblE5.Click, lblE6.Click, lblE7.Click, lblF1.Click, lblF2.Click, lblF3.Click, lblF4.Click, lblF5.Click, lblF6.Click, lblF7.Click, lblG1.Click, lblG2.Click, lblG3.Click, lblG4.Click, lblG5.Click, lblG6.Click, lblG7.Click, lblH1.Click, lblH2.Click, lblH3.Click, lblH4.Click, lblH5.Click, lblH6.Click, lblH7.Click, lblI1.Click, lblI2.Click, lblI3.Click, lblI4.Click, lblI5.Click, lblI6.Click, lblI7.Click, lblJ1.Click, lblJ2.Click, lblJ3.Click, lblJ4.Click, lblJ5.Click, lblJ6.Click, lblJ7.Click, lblK1.Click, lblK2.Click, lblK3.Click, lblK4.Click, lblK5.Click, lblK6.Click, lblK7.Click, lblL1.Click, lblL2.Click, lblL3.Click, lblL4.Click, lblL5.Click, lblL6.Click, lblL7.Click
ClickedBox = CType(sender, Label)
If ClickedBox.BackColor = Color.DodgerBlue Then 'Checks if seat is free
ClickedBox.BackColor = Color.LawnGreen 'Changes colour of seats clicked to green
ClickedBox.ForeColor = Color.LawnGreen
TotalNoOfSeats = TotalNoOfSeats + 1
SeatList.Add(ClickedBox.Name)
intCounter3 = intCounter3 + 1
Else
MsgBox("This seat has already been booked")
End If
End Sub
Edit: according to your last edit related to the ObjectDisposedException:
You cannot close the writer in the loop since a closed writer cannot be used anymore. So you should close it after the loop.
For intloop = 0 To NoOfClickedSeats - 1
FileWriter.WriteLine(SeatList(intloop))
Next
FileWriter.Close()
or use the Using-statement which also ensures that it gets closed/disposed in case of an error:
Using FileWriter = New StreamWriter("Seats " + AddFilm.strFilms(1, intSelectedFilm) + ".txt")
For intloop = 0 To NoOfClickedSeats - 1
FileWriter.WriteLine(SeatList(intloop))
Next
End Using

Check if the value of text box is inside the array

below is my array and code to check if the data in textbox is inside of the array. the problem is when i run the program the value of array is always " " or no data found.. what's wrong with my code? please help me.. thank you.
a = Split((a), vbTab)
devices = Array("iPhone5", "iPhone4", "iPhone3", "iPad", "iPod", "iPhone4s", "iPhone3G", "iPhone3gs", "gt-s5360", "gt-i9505", "n7100", "gt-n7100", "i9300", "gt-i9300", "gt-p3100", "s5300", "gt-s5300", "gt-s7562", _
"gt-i8190", "s100", "p5100", "gt-p5100", "gt-s6102", "gt-i9100", "gt-p3110", "gt-p6200", "n8000", "gt-n8000", "gt-i9082", "sm-t210", "gt-n7105", "n7000", "gt-n7000", "gt-n5100", "GT-S5570", "GT-S5830i", _
"GT-S5830", "GT-I8262", "GT-P1000", "Nexus 7", "GT-I8160", "H120", "ALCATEL ONE TOUCH 918N", "HuaweiG510-0200", "MyPhone A919 Duo", "MyPhone A848i Duo", "C6603", "ALCATEL ONE TOUCH 4030E", "LG-E400", _
"GT-P6800", "ICE 350e", "GT-I9070", "ALCATEL ONE TOUCH 5021E", "Cherry w500", "GT-I8150", "LT22i", "Spark TV", "I9500", "GT-I9500", "Burst S280", "W120", "GT-P7500", "MyPhone A888 Duo", "GT-S5301", "Thunder S220", "GT-S7500", _
"GT-I8552", "SM-T211", "GT-S5282", "A818 Duo", "LT26i", "GT-S6802", "GT-S5570I", "HuaweiY210-0100", "LT26w", "HTC One", "ST23i", "ST27i", "SHW-M250S", "Cruize W280", "Titan TV S320", "B1-A71", "GT-I9152", "W110", "7038", _
"LT18i", "GT-P3113", "GT-I9000", "Cherry Sonic", "GT-S5670", "SHW-M110S", "ST26i", "SonyEricssonMT25i", "Excite_352g", "LT25i", "Lenovo A390_ROW", "ST25i", "LG-E612", "GT-I9003")
urls = Array("youtube.com", "ytimg.com", "DoubleClick.net", "google.com", "fbcdn.net", "google -analytics.com", "yimg.com", "googlesyndication.com", "facebook.com", "gstatic.com", "mywebacceleration.com", "yahoo.com", "scorecardresearch.com", _
"google.com.ph", "adnxs.com", "redtubefiles.com", "rubiconproject.com", "wattpad.net", "www.com", "youjizz.com", "bing.net", "akamaihd.net", "xvideos.com", "tumblr.com", "twitter.com", "yieldmanager.com", "sharethis.com", "wikimedia.org", _
"y8.com", "sulitstatic.com", "globe.com.ph", "googleapis.com", "tagstat.com", "quantserve.com", "addthis.com", "blogspot.com", "king.com", "cloudfront.net", "ayosdito.com", "ask.com", "openx.net", "bigspeedpro.com", "gravatar.com", _
"amasvc.com", "bing.com", "cdn.com", "yldmgrimg.net", "cedexis.com")
For intX = 0 To UBound(a)
If Text11.Text = "" Then
a(intX) = UCase(a(intX))
Text11.Text = a(intX)
ElseIf Text12.Text = "" Then
a(intX) = UCase(a(intX))
Text12.Text = a(intX)
If Len(Text12.Text) <= 17 Then
Text12.Text = ""
Else
b = Split(Text12.Text, "/")
For i = 0 To UBound(b)
Text12.Text = b(2)
Next
Text12 = InStr(Text12, urls)
If Text12 = UCase(urls) Then
Text22 = Text12
Text25 = count + 1
Else
Text26 = Text12
Text27 = othercount + 1
End If
End If
You can use ForEach to make it more effective.
Or use this function... :)
Public Function IsContained(theArray() As Variant, strSearchPharse As String, Optional IsMatch As Boolean = False, Optional IsCaseSensitive As Boolean = True) As Boolean
On Error Resume Next
If Not UBound(theArray) 0 Then End
Dim strExploded As String
Dim gsChache As Boolean
gsChache = False 'set the default value
'Checking for every array thing
For Each strExploded In theArray
If IsMatch And Not (Len(strSearchPharse) = Len(strExploded)) Then 'if its matchable...
If IsCaseSensitive And strExploded = strSearchPharse Then gsChache = True
If Not IsCaseSensitive And LCase(strExploded) = LCase(strSearchPharse) Then gsChache = True
ElseIf Not IsMatch And Not IsCaseSensitive Then 'if its not matchable, and not case sensitive
If InStr(0, LCase(strExploded), LCase(strSearchPharse)) >= 1 Then gsChache = True
Else 'if its not matchable, and Case Sensitive
If InStr(0, strExploded, strSearchPharse) >= 1 Then gsChache = True
End If
DoEvents
Next strExploded
IsContained = gsChache 'finish
End Function
How to use it?
theArray is for array variable, strSearchPharse is the text you want to search (like keyword, e.g. apple or youtube), then isMatch is is the text you want to search is need to exactly same (not case sensitive, buat it will if you enable it.), IsCaseSensitive is the text you need to search on is need to case sensitive or not.
the default setting is, Not Matchable, and Case Sensitiveable.
Sample:
XYZ = Array("Satu", "Dua", "Tiga", "Empat", "Lima", "Enam", "Tujuh", "Delapan", "Sembilan", "Sepuluh")
If IsContained(XYZ, "o", , False) Then
MsgBox "The Array contains o alphabet."
Else
MsgBox "The Array have no o alphabet."
End If
The result will show "The Array contains o alphabet." MsgBox... :)

Recursively search files for information contained in excel cell and return path

Okedoke... I have an Excel spreadsheet with a filename in column A. The filenames listed in column A appear in one or more text files in one or more source directories.
I need Excel to search the text files recursively and return the path(s) of the file(s) that contain the filename specified in column A into column B. If more than one file go to column C etc.
The Excel sheet would be
__________________________________
__|______A___________|______B_____|
1 | filename.avi | |
2 | another_file.flv | |
The text files to search would be in multiple directories under C:\WebDocs\ and are DokuWiki pages some are quite short, such as this page that would need to be returned
===== Problem Description =====
Reopen a closed bank reconciliation.
===== Solution =====
Demonstration of the tool box routine that allows reposting of the bank rec.
{{videos:bank_rec_reopen1006031511.flv|}}
===== Additional Information -cm =====
You may have noticed that in the video there is a number to the right of the bank account number. In this case it was a 0. That indicates department 0 which is all departments. You get the department 0 if you have all departments combined using the option in the bank set up called "One Bank for All Departments". If this setting is not checked then when you create your starting bank rec for each department you will get a 1 to the right of the bank rec for department 1 and so on. You should normally only have a 0, or have numbers 1 or greater. If you have both, then the method was changed after the initial bank rec was made. You just have to be aware of this as you move forward. As always backup before you make any changes.
There are some other pages though that are quite long that do not contain videos but would be in the directories being searched. Format is the same, plain text, ==== are place holders for headings may contain links to other pages/sites.
I did find an existing VBA script that sort of does what I need it to. It does not recurse and returns too much information, date/time stamp for instance, where all I need is the path.
Private Sub CommandButton1_Click()
Dim sh As Worksheet, rng As Range, lr As Long, fPath As String
Set sh = Sheets(1) 'Change to actual
lstRw = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
Set rng = sh.Range("A2:A" & lstRw)
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
fPath = .SelectedItems(1)
End With
If Right(fPath, 1) <> "\" Then
fPath = fPath & "\"
End If
fwb = Dir(fPath & "*.*")
x = 2
Do While fwb <> ""
For Each c In rng
If InStr(LCase(fwb), LCase(c.Value)) > 0 Then
Worksheets("Sheet2").Range("C" & x) = fwb
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(fwb)
Worksheets("Sheet2").Range("D" & x) = f.DateLastModified
Worksheets("Sheet2").Range("B" & x) = f.Path
Worksheets("sheet2").Range("A" & x) = c.Value
Columns("A:D").AutoFit
Set fs = Nothing
Set f = Nothing
x = x + 1
End If
Next
fwb = Dir
Loop
Set sh = Nothing
Set rng = Nothing
Sheets(2).Activate
End Sub
My attempts at moification so far have generally resulted in a broken script and have thus led me here asking for help.
Thanks,
Simon
Downlaoded the win32 port of the GNU tool grep from http://gnuwin32.sourceforge.net/
Saved the list of video files into a plain text file instead of using a spreadsheet.
grep --file=C:\file_containing video_file_names.txt -R --include=*.txt C:\Path\To\Files >grep_output.txt
The information written to the grep_output.txt file looked like
C:\wiki_files\wiki\pages/my_bank_rec_page.txt:{{videos:bank_rec_reopen1006031511.flv|}}
So there was the path to the file containing the video name and the video name on one line.
Imported the grep_output.txt file into a new Excel workbook.
Used regular formulae to do the following
Split Column A at the "/" to give the path in Column A and the page and video information in Column B
Split the data in in Column B at the ":{{" characters leaving page name in Column B and video information in Column C
Stripped the :{{ and |}} from the front and rear of the string in Column C
From my limited experience, it seems you'd want to perform 4 tasks.
1) Loop through Directories
2) Loop through files per directory (Good idea to keep the filename in a variable)
3) Test the text file for values. Would suggest clear a "scribble sheet", import the file, run a check. e.g.
Sheets("YourScratchPatch").Select
Application.CutCopyMode = False
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & yourpath & yourfile.txt, Destination:=Range("A1"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
4) if values are found, write the file name variable to the index sheet.
I'm sure there should be better (arrays?) ways to do the comparison check as well, but it depends on what's inside the text file (i.e. just one file name?)
More info on the text file structure would be useful. Hope this helps.

VB Script writing to MultiString reg key

I'm writing a script that looks at the current home page of IE. if it is something other than our intranet I grab that value and merge it in to the secondary pages reg key.
Now I have figured out how merge it in to an array(assuming that there are some secondary pages... if there are no big deal). What I am running in to is that there seems to be an extra line when I finally merge it. It's driving me nuts. Any thoughts? Here is the function. There is more tot he script but this is the part that is painful. Thanks
Function AppendSecondary(StrComputer)
objReg.GetstringValue HKEY_CURRENT_USER, strKeyPath, ValueName, strValueMain
objReg.SetStringValue HKEY_CURRENT_USER, strKeyPath, ValueName, strValueMyMTD
set ws = WScript.CreateObject("Wscript.Shell")
strKeyPath=WS.RegRead(strKeyPathPath & ValueNameSecondary)
if vartype(strKeyPath)= vbArray + vbVariant then
arStrings = strKeyPath
else
arStrings = split(strKeyPath,chr(0))
redim preserve arStrings(ubound(arStrings)-3)
end If
redim preserve arStrings(ubound(arStrings)+1)
arstrings(ubound(arStrings))= strvaluemain
arstrings1 = join(arStrings,VBCRLF)
arstringsnew = Array(arstrings1)
objReg.SetMultiStringValue HKEY_CURRENT_USER, strKeyPath, ValueNameSecondary, arstringsnew
End Function
Check the last element of each array to make sure it's not a null string ("") or a non-printing character like Chr(10) or Chr(13) or vbCR, vbLF or vbCRLF.
Interesting question.
Just out of curiosity, why do you merge an array, then rebuild it as an array later on?
arstrings1 = join(arStrings,VBCRLF) 'merge
arstringsnew = Array(arstrings1) 'reassemble
Regardless, I think your split on "chr(0)" is creating this issue and a simple revision too the join command will suffice.
arstrings1 = trim(join(arstrings,vbcrlf))
of if not the case, a quick loop'd'loop
dim nArray() : Redim nArray(0)
for each str in arstrings
if len(str)>0 then
nArray(ubound(nArray)) = str
redim preserve nArray(ubound(nArray)+1)
end if
next
arrstringsnew = nArray

Resources