Issue - We have a spreadsheet with thousands of addresses but no counties.
Goal - We would like to add counties into each record. We can identify counties using Zip Codes and have a list of Zip Codes and county names.
What I've tried so far - The county names are in Column A and it's corresponding Zip Code is in Column B. I copied the address list into the same spreadsheet starting with their Zip Codes in Column D.
I wrote the following simple macro to compare and replace Zip Codes with County names. It runs but doesn't seem to replace anything. I don't get any errors, so I'm not sure where the problem is. Any ideas?
Public Sub Take_Two_Replace_Zip_With_Name()
Dim LastBCell As Long
Dim B As Integer
Dim Bcell As Range
LastBCell = ActiveSheet.Range("B65000").End(xlUp).Row
For B = LastBCell To 2 Step -1
Set Bcell = ActiveSheet.Cells(B, 2)
If Bcell = Bcell.Offset(0, 2) Then Bcell.Offset(0, 2) = Bcell.Offset(0, -1)
Next B
End Sub
OK, I worked it out myself:
For Each Bcell In Range("B2:B100").Cells
Columns("D:D").Cells.Replace What:=Bcell, Replacement:=Bcell.Offset(0, -1).Value, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next Bcell
Related
I have a system that I can output a spreadsheet from. I then take this outputted spreadsheet and import it into MS Access. There, I run some basic update queries before merging the final result into a SharePoint 2013 Linked List.
The spreadsheet I output has an unfortunate Long Text field which has some comments in it, which are vital. On the system that hosts the spreadsheet, these comments are nicely formatted. When the spreadsheet it output though, the field turns into a long, very unpretty string like so:
09:00 on 01/03/2017, Firstname Surname. :- Have responded to request for more information. 15:12 on 15/02/2017, Firstname Surname. :- Need more information to progress request. 17:09 on 09/02/2017, Firstname Surname. :- Have placed request.
What I would like to do is run a query (either in MS Access or MS Excel) which can scan this field, detect occurrences of "##:## on ##/##/####, Firstname Surname. :-" and then automatically insert a line break before them, so this text is more neatly formatted. It would obviously skip the first occurrence of this format, as otherwise it would enter a new line at the start of the field. Ideal end result would be:
09:00 on 01/03/2017, Firstname Surname. :- Have responded to request
for more information.
15:12 on 15/02/2017, Firstname Surname. :- Need more information to progress request.
17:09 on 09/02/2017, Firstname Surname. :- Have placed request.
To be honest, I haven't tried much myself so far, as I really don't know where to start. I don't know if this can be done without regular expressions, or within a simple query versus VBA code.
I did start building a regular expression, like so:
[0-9]{2}:[0-9]{2}\s[o][n]\s[0-9]{2}\/[0-9]{2}\/[0-9]{4}\,\s
But this looks a little ridiculous and I'm fairly certain I'm going about it in a very unnecessary way. From what I can see from the text, detecting the next occurrence of "##:## on ##/##/####" should be enough. If I take a new line after this, that will suffice.
You have your RegExp pattern, now you need to create a function to append found items with your extra delimiter.
look at this function. It takes, your long string and finds your date-stamp using your pattern and appends with your delimiter.
Ideally, i would run each line twice and add delimiters after each column so you have a string like,
datestamp;firstname lastname;comment
you can then use arr = vba.split(text, ";") to get your data into an array and use it as
date-stamp = arr(0)
name = arr(1)
comment = arr(2)
Public Function FN_REGEX_REPLACE(iText As String, iPattern As String, iDelimiter As String) As String
Dim objRegex As Object
Dim allmatches As Variant
Dim I As Long
On Error GoTo FN_REGEX_REPLACE_Error
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Multiline = True
.Global = True
.IgnoreCase = True
.Pattern = iPattern
If .test(iText) Then
Set allmatches = .Execute(iText)
If allmatches.count > 0 Then
For I = 1 To allmatches.count - 1 ' for i = 0 to count will start from first match
iText = VBA.Replace(iText, allmatches.item(I), iDelimiter & allmatches.item(I))
Next I
End If
End If
End With
FN_REGEX_REPLACE = Trim(iText)
Set objRegex = Nothing
On Error GoTo 0
Exit Function
FN_REGEX_REPLACE_Error:
MsgBox Err.description
End Function
use above function as
mPattern = "[0-9]{2}:[0-9]{2}\s[o][n]\s[0-9]{2}\/[0-9]{2}\/[0-9]{4}\,"
replacedText = FN_REGEX_REPLACE(originalText,mPattern,vbnewline)
Excel uses LF for linebreaks, Access uses CRLF.
So it should suffice to run a simple replacement query:
UPDATE myTable
SET LongTextField = Replace([LongTextField], Chr(10), Chr(13) & Chr(10))
WHERE <...>
You need to make sure that this runs only once on newly imported records, not repeatedly on all records.
Right now I am doing coding to set a filter for a data chart. Basically, I don't know how to post the data sheet up here so just try to type them ):
(starting from the left is column A)
Name * BDevice * Quantity * Sale* Owner
Basically I need to filter out for 2 column:
-The BDevice with any word contain "M1454" or "M1467" or "M1879" (It means that M1454A or M1467TR would still fit in)
-The Owner with PROD or RISK
Here is the code I wrote:
Sub AutoFilter()
ActiveWorkbook.ActiveSheet..Range(B:B).Select
Selection.Autofilter Field:=1 Criteria1:=Array( _
"*M1454*", "*M1467*", "*M1879*"), Operator:=xlFilterValues
Selection.AutoFilter Field:=4 Criteria1:="=PROD" _
, Operator:=xlOr, Criteria2:="=RISK"
End Sub
When I run the code, the machine returns error 1004 and the part which seems to be wrong is the Filter part 2 ( I am not sure about the use of Field, so I can not say it for sure)
Edit; Santosh: When I try your code, the machine gets error 9 subscript out of range. The error came from the with statement. (since the data table has A to AS column so I just change to A:AS)
While there is a maximum of two direct wildcards per field in the AutoFilter method, pattern matching can be used to create an array that replaces the wildcards with the Operator:=xlFilterValues option. A Select Case statement helps the wildcard matching.
The second field is a simple Criteria1 and Criteria2 direct match with a Operator:=xlOr joining the two criteria.
Sub multiWildcardFilter()
Dim a As Long, aARRs As Variant, dVALs As Object
Set dVALs = CreateObject("Scripting.Dictionary")
dVALs.CompareMode = vbTextCompare
With Worksheets("Sheet1")
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
'build a dictionary so the keys can be used as the array filter
aARRs = .Columns(2).Cells.Value2
For a = LBound(aARRs, 1) + 1 To UBound(aARRs, 1)
Select Case True
Case aARRs(a, 1) Like "MK1454*"
dVALs.Add Key:=aARRs(a, 1), Item:=aARRs(a, 1)
Case aARRs(a, 1) Like "MK1467*"
dVALs.Add Key:=aARRs(a, 1), Item:=aARRs(a, 1)
Case aARRs(a, 1) Like "MK1879*"
dVALs.Add Key:=aARRs(a, 1), Item:=aARRs(a, 1)
Case Else
'no match. do nothing
End Select
Next a
'filter on column B if dictionary keys exist
If CBool(dVALs.Count) Then _
.AutoFilter Field:=2, Criteria1:=dVALs.keys, _
Operator:=xlFilterValues, VisibleDropDown:=False
'filter on column E
.AutoFilter Field:=5, Criteria1:="PROD", Operator:=xlOr, _
Criteria2:="RISK", VisibleDropDown:=False
'data is filtered on MK1454*, MK1467* or MK1879* (column B)
'column E is either PROD or RISK
'Perform work on filtered data here
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
dVALs.RemoveAll: Set dVALs = Nothing
End Sub
If exclusions¹ are to be added to the filtering, their logic should be placed at the top of the Select.. End Select statement in order that they are not added through a false positive to other matching criteria.
Before applying AutoFilter Method
After applying AutoFilter w/ multiple wildcards
¹ See Can Advanced Filter criteria be in the VBA rather than a range? and Can AutoFilter take both inclusive and non-inclusive wildcards from Dictionary keys? for more on adding exclusions to the dictionary's filter set.
For using partial strings to exclude rows and include blanks you should use
'From Jeeped's code
Dim dVals As Scripting.Dictionary
Set dVals = CreateObject("Scripting.Dictionary")
dVals.CompareMode = vbTextCompare
Dim col3() As Variant
Dim col3init As Integer
'Swallow row3 into an array; start from 1 so it corresponds to row
For col3init = 1 to Sheets("Sheet1").UsedRange.Rows.count
col3(col3init) = Sheets("Sheet1").Range(Cells(col3init,3),Cells(col3init,3)).Value
Next col3init
Dim excludeArray() As Variant
'Partial strings in below array will be checked against rows
excludeArray = Array("MK1", "MK2", "MK3")
Dim col3check As Integer
Dim excludecheck as Integer
Dim violations As Integer
For col3check = 1 to UBound(col3)
For excludecheck = 0 to UBound(excludeArray)
If Instr(1,col3(col3check),excludeArray(excludecheck)) <> 0 Then
violations = violations + 1
'Sometimes the partial string you're filtering out for may appear more than once.
End If
Next col3check
If violations = 0 and Not dVals.Exists(col3(col3check)) Then
dVals.Add Key:=col3(col3check), Item:=col3(col3check) 'adds keys for items where the partial strings in excludeArray do NOT appear
ElseIf col3(col3check) = "" Then
dVals.Item(Chr(61)) = Chr(61) 'blanks
End If
violations = 0
Next col3check
The dVals.Item(Chr(61)) = Chr(61) idea came from Jeeped's other answer here
Multiple Filter Criteria for blanks and numbers using wildcard on same field just doesn't work
Try below code :
max 2 wildcard expression for Criteria1 works. Refer this link
Sub AutoFilter()
With ThisWorkbook.Sheets("sheet1").Range("A:E")
.AutoFilter Field:=2, Criteria1:=Array("*M1454*", "*M1467*"), Operator:=xlFilterValues
.AutoFilter Field:=5, Criteria1:="=PROD", Operator:=xlOr, Criteria2:="=RISK"
End With
End Sub
I'm hoping I can get come help from a programmer.
What I want to do is to translate a word report generated by a software, so I turned to macros. I already have a word file containing the original word/phrases and the translated ones.
I 'stole' the code to translate from some forum online, which works great with normal text. My problem is that the text of the report I want to translate is within various "text boxes" and "tables".
I was able to manually remove the tables, but keep the text. This totally ruined the formatting, but I can deal with that latter.
Now, unfortunately I cannot do the same with textboxes. There is no 'delete, but keep the text" function for textboxes.
I can send you the macro code, the original report automatically generated by the software and the file to get all translated words from.
I really appreciate your time.
Ok. This is code that translates normal text.
Sub Translate()
Dim oChanges As Document, oDoc As Document
Dim oTable As Table
Dim oRng As Range
Dim rFindText As Range, rReplacement As Range
Dim i As Long
Dim sFname As String
'Change the path in the line below to reflect the path of the table document
sFname = "C:\Users\user\Desktop\Dictionary.doc"
Set oDoc = ActiveDocument
Set oChanges = Documents.Open(FileName:=sFname, Visible:=False)
Set oTable = oChanges.Tables(1)
For i = 1 To oTable.Rows.Count
Set oRng = oDoc.Range
Set rFindText = oTable.Cell(i, 1).Range
rFindText.End = rFindText.End - 1
Set rReplacement = oTable.Cell(i, 2).Range
rReplacement.End = rReplacement.End - 1
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
Do While .Execute(findText:=rFindText, _
MatchWholeWord:=True, _
MatchWildcards:=False, _
Forward:=True, _
Wrap:=wdFindContinue) = True
oRng.Text = rReplacement
Loop
End With
Next i
oChanges.Close wdDoNotSaveChanges
End Sub
I'm guessing you'd need to see the format of the document that is being translated, which contains all the tables and text boxes. But it is too large and I'm not sure if I can send it as an attachment here somehow. (sorry, its my first time on this forum). Any advise?
Thanks a lot
JD
I am using sheet 2 to pull data out of sheet 1.
A9 has this formula in it:
=(INDEX(sheet1!$G$9:$G$7000,MATCH(0,INDEX(COUNTIF($A$8:A8,sheet1!$G$9:$G$7000),0,0),0))
(it looks through column G and takes out duplicates and blanks)
B9 has this formula:
=IF(MAX(IF($A9=sheet1!G:G,sheet1!E:E))=MIN(IF($A9=sheet1!G:G,sheet1!E:E)),"Only 1 Entry",MAX(IF($A9=sheet1!G:G,sheet1!E:E))-MIN(IF($A9=sheet1!G:G,sheet1!E:E)))
(this one looks in column A on sheet2 then looks up dates, Min and Max on Sheet1 to determine how old a certain item is)
C9 has this formula:
=SUMIF(sheet1!$G$9:$G$7000,A9,sheet1!$B$9:$B$7000)
(this on looks as column A in sheet 2 and references sheet1 to add up hours)
The problem is that if I sort Column C on sheet2 nothing changes. I think because as it tries to filter it the dynamic formula is reordering it back to what it is on sheet 1. Basically no matter how you try and filter it, the list stays the same, as its based on sheet1. I even tried to sort the columns on sheet 1 to see if sheet 2 would change but since data in column C of sheet 2 dont actually exist on sheet 1 that doesnt work either.
How can I filter Column C or even B and others with this dynamic formulas that are in place?
I have searched online to find a solution but cant find anything that works. If I can not use this dynamic list, I thought maybe I could create the list in column A sheet 2 with VBA and make the list static.
I have searched too for a VBA to remove duplicated and blanks but for some reason am coming up with a blank on it. I have found some that did part but not both.
Sub MakeUnique()
Dim vaData As Variant
Dim colUnique As Collection
Dim aOutput() As Variant
Dim i As Long
'Put the data in an array
vaData = Sheet1.Range("A5:A7000").Value
'Create a new collection
Set colUnique = New Collection
'Loop through the data
For i = LBound(vaData, 1) To UBound(vaData, 1)
'Collections can't have duplicate keys, so try to
'add each item to the collection ignoring errors.
'Only unique items will be added
On Error Resume Next
colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
On Error GoTo 0
Next i
'size an array to write out to the sheet
ReDim aOutput(1 To colUnique.Count, 1 To 1)
'Loop through the collection and fill the output array
For i = 1 To colUnique.Count
aOutput(i, 1) = colUnique.Item(i)
Next i
'Write the unique values to column B
Sheet2.Range("A9").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
End Sub
This VBA creates a list of no duplicates but leaves blanks...
So, how can I have columns B and C on sheet 2 be sortable with column A being derived from data on sheet 1 with no duplicates and no blanks? Is there a way to sort and use the dynamic formula or should it be done with VBA?
This version of your posted code will not include blanks in the unique list:
Sub MakeUnique()
Dim vaData As Variant
Dim colUnique As Collection
Dim aOutput() As Variant
Dim i As Long
'Put the data in an array
vaData = Sheet1.Range("A5:A7000").Value
'Create a new collection
Set colUnique = New Collection
'Loop through the data
For i = LBound(vaData, 1) To UBound(vaData, 1)
'Collections can't have duplicate keys, so try to
'add each item to the collection ignoring errors.
'Only unique items will be added
If vaData(i, 1) <> "" Then
On Error Resume Next
colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
On Error GoTo 0
End If
Next i
'size an array to write out to the sheet
ReDim aOutput(1 To colUnique.Count, 1 To 1)
'Loop through the collection and fill the output array
For i = 1 To colUnique.Count
aOutput(i, 1) = colUnique.Item(i)
Next i
'Write the unique values to column B
Sheet2.Range("A9").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
End Sub
I'm working with 7 dynamic dependent lists, and I thought the best way to automate the process and avoid to arrange anything in a future if I modify the lists was a VBA code.
The VBA code that I started to work on it is posted on: Dynamic Depending Lists in Separated WorkSheets in VBA
That code is just for the 2 first lists.
That's the main table that I have. I want pick lists for the first row only for the yellow columns:
That's the table that I have the lists (they must be dynamic):
The relations between my lists are:
Responsible list and Site list are related with Project list.
The other lists are related with the site list.
Okay. I've got what you are looking for. I solved this issue a few months back in another project. Basically, indirect is no good here because it doesn't work on dynamic named ranges, because they don't produce an actual result, just a formula reference.
First, set up your named ranges on a sheet like so. It's very important that the named ranges be named in the manner I described, as this will feed the code into making your dynamic lists. Also, note, I only wrote out SamplePoints for X1 and T2. If you select other options, the code won't work until you add those named ranges in.
Then assuming input sheet is set up like below:
Place this code in the worksheet change event of your input sheet. What it does is take the value selected in one cell and then appends the appropriate column name to feed that list. So, if Project A is selected and you want to pick a responsible party for project A, it sets the validation in Range("B(whatever row you are on)" to be A_Responsible, thus giving you that list.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wks As Worksheet
Dim strName As String, strFormula
Dim rng As Range
Set wks = ActiveSheet
With wks
If Target.Row = 1 Then Exit Sub
Select Case Target.Column
Case Is = .Rows(1).Find("Project", lookat:=xlWhole).Column
Set rng = Target.Offset(, 1)
strName = Target.Value
strFormula = "=" & Replace(strName, " ", "_") & "_Responsible"
AddValidation rng, 1, strFormula
'add any more cells that would need validation based on project selection here.
Case Is = .Rows(1).Find("Responsible", lookat:=xlWhole).Column
Set rng = Target.Offset(, 1)
strName = Target.Value
strFormula = "=" & Replace(strName, " ", "_") & "_SamplePoint"
AddValidation rng, 1, strFormula
'add any more cells that would need validation based on responsible selection here.
'Case Is = add any more dependenices here ... and continue with cases for each one
End Select
End With
You will also need this function in a standard module somewhere in your workbook.
Function AddValidation(ByVal rng As Range, ByVal iOperator As Integer, _
ByVal sFormula1 As String, Optional iXlDVType As Integer = 3, _
Optional iAlertStyle As Integer = 1, Optional sFormula2 As String, _
Optional bIgnoreBlank As Boolean = True, Optional bInCellDropDown As Boolean = True, _
Optional sInputTitle As String, Optional sErrorTitle As String, _
Optional sInputMessage As String, Optional sErrorMessage As String, _
Optional bShowInput As Boolean = True, Optional bShowError As Boolean = True)
'==============================================
'Enumaration for ease of use
'XlDVType
'Name Value Description
'xlValidateCustom 7 Data is validated using an arbitrary formula.
'xlValidateDate 4 Date values.
'xlValidateDecimal 2 Numeric values.
'xlValidateInputOnly 0 Validate only when user changes the value.
'xlValidateList 3 Value must be present in a specified list.
'xlValidateTextLength 6 Length of text.
'xlValidateTime 5 Time values.
'xlValidateWholeNumber 1 Whole numeric values.
'AlertStyle
'xlValidAlertInformation 3 Information icon.
'xlValidAlertStop 1 Stop icon.
'xlValidAlertWarning 2 Warning icon.
'Operator
'xlBetween 1 Between. Can be used only if two formulas are provided.
'xlEqual 3 Equal.
'xlGreater 5 Greater than.
'xlGreaterEqual 7 Greater than or equal to.
'xlLess 6 Less than.
'xlLessEqual 8 Less than or equal to.
'xlNotBetween 2 Not between. Can be used only if two formulas are provided.
'xlNotEqual 4 Not equal.
'==============================================
With rng.Validation
.Delete ' delete any existing validation before adding new one
.Add Type:=iXlDVType, AlertStyle:=iAlertStyle, Operator:=iOperator, Formula1:=sFormula1, Formula2:=sFormula2
.IgnoreBlank = bIgnoreBlank
.InCellDropdown = bInCellDropDown
.InputTitle = sInputTitle
.ErrorTitle = sErrorTitle
.InputMessage = sInputMessage
.ErrorMessage = sErrorMessage
.ShowInput = bShowInput
.ShowError = bShowError
End With
End Function