Check if the value of text box is inside the array - arrays

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... :)

Related

How to compare array to array using VBScript?

I would like to check a data in my file exist or not in an array data that I have. It will return 1 and 0 if its exit or not. Inside my file is like this:
2j2H4F6d9d0d3hdfasgt.y7
But I cut the last 2 lines. And my array data is like this: [2w fr 5k 2j 0w]. I want to check whether my array data exist inside my file.
Const wbemFlagReturnImmediately = &h10
Const wbemFlagForwardOnly = &h20
XX = 0
Set wshShell = CreateObject("WScript.Shell")
strFBString = wshShell.ExpandEnvironmentStrings("%FB%")
WScript.Echo "==>"
WScript.Echo "strFBString: " & strFBString
Set wshShell = Nothing
For i = 1 To Len(strFBString) Step 2
If StrComp(Mid(strFBString, i, 2), [2w fr 5k 2j 0w]) = 0 Then
XX = 1
End If
Next
WScript.Echo "XX: " & XX
WScript.Quit(XX)
For one thing, [2w fr 5k 2j 0w] is not a valid array definition in VBScript. If you want to define an array with these 5 string elements you need to do it like this:
Array("2w", "fr", "5k", "2j", "0w")
Also, StrComp() is for comparing a string to another string. It does not support comparing a string to an array. For comparing a string to each element of an array you need a loop. How to build that loop depends on the result you want to achieve, though.
Looking at your code it seems you want to find a match in 2j2H4..., but not in w2j2H..., so simply using InStr() probably won't work for you. In that case you could use an inner loop for the comparison:
ref = Array("2w", "fr", "5k", "2j", "0w")
For i = 1 To Len(strFBString) Step 2
For Each s In ref
If Mid(strFBString, i, 2) = s Then
'...
End If
Next
Next
But like I already said, details depend on the desired end result. If you want to check if your input string contains any of the array values you could do something like this:
ref = Array("2w", "fr", "5k", "2j", "0w")
found = False
For i = 1 To Len(strFBString) Step 2
For Each s In ref
If Mid(strFBString, i, 2) = s Then
found = True
Exit For
End If
Next
Next
If on the other hand you wanted to check if your input string contains all of the reference strings you'd probably do something like this instead:
ref = Array("2w", "fr", "5k", "2j", "0w")
For Each s In ref
found = False
For i = 1 To Len(strFBString) Step 2
If Mid(strFBString, i, 2) = s Then
found = True
Exit For
End If
Next
If Not found Then Exit For
Next
You could also use an entirely different approach, like putting your data in a dictionary:
data = CreateObject("Scripting.Dictionary")
For i = 1 To Len(strFBString) Step 2
data(Mid(strFBString, i, 2)) = True
Next
Using that approach you could check if the data contains any of the reference values like this:
found = False
For s In Array("2w", "fr", "5k", "2j", "0w")
If data.Exists(s) Then
found = True
Exit For
End If
Next
or check if the data contains all of the reference values like this:
found = True
For s In Array("2w", "fr", "5k", "2j", "0w")
If Not data.Exists(s) Then
found = False
Exit For
End If
Next

highlight cell based on value, mulptie search array

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

Using two array's in one application with progressing the arrays

I have the below code I'm trying to put together and I'm running into a Run-time error '9' subscript out of range. This does work through the first run through then errors. I don't see why it won't allow for the string to go forward. From what I'm reading it should go through the application changing the X values with Y value 1 and when completed with that set to go to the next Y and start the whole process again until the end of Y. Any help would be appreciated.
Dim Cat(1 To 10) As String
Cat(1) = "010" 'SD
Cat(2) = "020" 'FD
Cat(3) = "050" 'WVID
Cat(4) = "040" 'VID
Cat(5) = "030" 'MEM
Cat(6) = "080" 'ACC
Cat(7) = "060" 'HDMI
Cat(8) = "070" 'SSD
Cat(9) = "090" 'POWER
Cat(10) = "990" 'ZRM
Dim Month(1 To 12) As String
Month(1) = "January"
Month(2) = "February"
Month(3) = "March"
Month(4) = "April"
Month(5) = "May"
Month(6) = "June"
Month(7) = "July"
Month(8) = "August"
Month(9) = "September"
Month(10) = "October"
Month(11) = "November"
Month(12) = "December"
For Y = 1 To UBound(Cat)
For X = 1 To UBound(Month)
Month(X) = Application.WorksheetFunction.SumIf(Sheets(Month(X)).Columns("AO"), Cat(Y), Sheets(Month(X)).Columns("AG"))
Next X
Cells(3 + Y, 41).Value = Application.WorksheetFunction.Sum(Month(1), Month(2), Month(3), Month(4), Month(5), Month(6), Month(7), Month(8), Month(9), Month(10), Month(11), Month(12))
Next Y
End Sub
On the first run through the loop indexed by X you are computing a conditional sum of data stored in Sheet "January". And then overwriting "January" with that value in Month(X). Let's say that that value is 42. On your next run through the loop 42 is in Month(X) so you are looking for Sheets(42), which probably isn't a valid worksheet. I would try this instead.
dim temp as double
For Y = 1 To UBound(Cat)
temp = 0# '0 as a double.
For X = 1 To UBound(Month)
temp = temp + Application.WorksheetFunction.SumIf(Sheets(Month(X)).Columns("AO"), Cat(Y), Sheets(Month(X)).Columns("AG"))
Next X
Cells(3 + Y, 41).Value = temp
Next Y
This way we don't need to store all of the sums from each sheet, since we only use them to add them all together.

How do I randomize an array in Visual Basic 2010?

I have any array of questions like this:
Dim Questions(25) As TheQuestions
Function loadQuestions()
Questions(0).Question = "Which of these words are an adjective?"
Questions(0).option1 = "Dog"
Questions(0).option2 = "Beautiful"
Questions(0).option3 = "Steven"
Questions(0).option4 = "Bird"
Questions(0).Answer = "B"
Questions(1).Question = "What's the adjective in this sentence:" & vbCrLf & "'Kelly handled the breakable glasses very carefully'"
Questions(1).option1 = "Kelly"
Questions(1).option2 = "Handled"
Questions(1).option3 = "Carefully"
Questions(1).option4 = "Breakable"
Questions(1).Answer = "D"
Questions(2).Question = "What's the adjective in this sentence: 'Karen is a graceful dancer'"
Questions(2).option1 = "Is"
Questions(2).option2 = "Graceful"
Questions(2).option3 = "Dancer"
Questions(2).option4 = "Tanya"
Questions(2).Answer = "B"
...
I have found a way of randomizing the question successfully, but could I make sure that the correct, four potential answers are displayed along with the question being displayed?
Below is the code for calling the Function which gets the question and then displays it in a label (lblQuestion) and where the code I am looking for needs to go, I am guessing:
Function GetQuestion(ByVal intQuestion As Integer)
tmrOne.Start()
If questionNumber < 25 Then
lblQuestionNumber.Text = "Question" & " " & questionNumber
lblQuestion.Text = Questions(intQuestion).Question
btnAnswerA.Text = Questions(intQuestion).option1
btnAnswerB.Text = Questions(intQuestion).option2
btnAnswerC.Text = Questions(intQuestion).option3
btnAnswerD.Text = Questions(intQuestion).option4
strAnswer = Questions(intQuestion).Answer
questionNumber = questionNumber + 1
btnAnswerA.BackColor = Color.White
btnAnswerB.BackColor = Color.White
btnAnswerC.BackColor = Color.White
btnAnswerD.BackColor = Color.White
btnAnswerA.Enabled = True
btnAnswerB.Enabled = True
btnAnswerC.Enabled = True
btnAnswerD.Enabled = True
Return intQuestion
Else
MsgBox("You have finished")
End
End If
End Function
I used this:
lblQuestion.Text = Questions(random.Next(25)).Question
It randomizes the question, but how do I get it so that the four possible answers are shown with the correct question, like in the array above where there are FOUR options.
Many thanks!
Instead of:
lblQuestion.Text = Questions(random.Next(25)).Question
I think you just need to save the random number and do it like this:
dim questionChosen as int
questionChosen = random.Next(25)
lblQuestion.Text = Questions(questionChosen).Question
Then you update the rest of the fields using Questions(questionChosen).WhateverYouNeed

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.

Resources