Error putting a variable inside excel VBA function - excel

Sub airtableCleaner()
Dim x As Integer
Dim argCounter As Integer
Dim A As String
Dim B As String
Dim folderLocation As Variant
Dim Answer As VbMsgBoxResult
'Ask user if they want to run macro
Answer = MsgBox("Do you want to run this macro? Please use airtable Download as CSV - Column 1: Primary key, Column 2: Airtable Linkz", vbYesNo, "Run Macro")
If Answer = vbYes Then
folderLocation = Application.InputBox("Enter a folder location where your image assets will be")
'Cleanup to just amazons3 dl.airtable links
Columns("B:B").Select
Selection.Replace What:="* ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="(", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:=")", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Count Cells
Range("B2").Activate
Do
If ActiveCell.Value = "" Then Exit Do
ActiveCell.Offset(1, 0).Activate
argCounter = argCounter + 1
Loop
'Copy Image Links to new cells to format in Column C
Columns("B:B").Select
Selection.Copy
Columns("C:C").Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Clean up links to only have names in Column C
Selection.Replace What:="https://dl.airtable.com/", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False
'Create Batch on Column D
Range("D2").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(""COPY "",CHAR(34),RC[-1],CHAR(34),"" "", CHAR(34), [" & folderLocation & "],RC[-3],"".png"",CHAR(34))"
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:D9")
Range("D2:D9").Select
'Delete header row 1 information
Rows("1:1").Select
Selection.Delete Shift:=xlUp
'Repaste values back into column D removing formulas
Columns("D:D").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End If
End Sub
I have this set of excel VBA code. I'm getting an error
Run-time error '1004' Application-defined or object-defined error
At this line
"=CONCATENATE(""COPY "",CHAR(34),RC[-1],CHAR(34),"" "", CHAR(34), [" & folderLocation & "],RC[-3],"".png"",CHAR(34))"
I have been setting folderLocation variable value as c:\doge and making a file folder reflecting this
My code was working fine until I introduced a variable inside of an excel function
What am I doing wrong here?
EDIT
this was the original formula I was using
=CONCATENATE("COPY ",CHAR(34),C5,CHAR(34)," ", CHAR(34), "c:\doge\",A5,".png",CHAR(34))
where c:\doge\ was the place I wanted to input the user input at.

Is this what you are trying?
folderLocation = "c:\doge\"
Range("D2").Formula = "=CONCATENATE(""COPY "",CHAR(34),C5,CHAR(34),"" "", CHAR(34), " & _
Chr(34) & folderLocation & Chr(34) & ",A5,"".png"",CHAR(34))"

Related

Loop VBA All Sheet Except MasterSheet

My code is
Sub Macro5()
'
' Macro5 Macro
'
Range("A7").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Columns.AutoFit
Range("A8").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=R4C2"
Range("A8").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Range("A7").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.AutoFilter
Selection.Columns.AutoFit
ActiveWindow.SmallScroll ToRight:=15
ActiveSheet.Range("$A$7:$AC$38").AutoFilter Field:=20, Criteria1:="0"
ActiveSheet.Range("$A$7:$AC$38").AutoFilter Field:=22, Criteria1:="0"
ActiveWindow.SmallScroll ToRight:=-45
Range("A13").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Cells.Select
Range("A22").Activate
Selection.AutoFilter
Range("A11").Select
Columns("E:E").Select
Application.CutCopyMode = False
Selection.Replace What:="Discovery Ads", Replacement:="Qua" & ChrW(777) & "ng Ca" & ChrW(769) & "o Kha" _
& ChrW(769) & "m Pha" & ChrW(769) _
, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat _
:=False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Columns("E:E").Select
Selection.Replace What:="Product Search Ad", Replacement:= _
"Qua" & ChrW(777) & "ng Ca" & ChrW(769) & "o Ti" _
& ChrW(768) & "m Kiê" & ChrW(769) & "m Sa" & ChrW(777) & "n Phâ" & ChrW( _
777) & "m", LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, _
FormulaVersion:=xlReplaceFormula2
Columns("E:E").Select
Selection.Replace What:="Shop Search Ad", Replacement:= _
"Qua" & ChrW(777) & "ng Ca" & ChrW(769) & "o Ti" _
& ChrW(768) & "m Kiê" & ChrW(769) & "m Shop", LookAt:=xlPart, SearchOrder:=xlByRows, _
MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False, _
FormulaVersion:=xlReplaceFormula2
Selection.AutoFilter
End Sub
So i have insert this code before code
Dim ws As Worksheet
For Each ws In Sheets
And insert more prepend every Range...Select like
ws.Range("A7").Select
But it not work for me. So is there any other way to do it?. Loop VBA all sheet in that workbook except "MasterSheet"
About my data it look like this :
enter image description here
So i wanna change A7:A end down is value B4.
-Then filter, Filter column T,V every value = 0 and delete it
Replace some name
And this is final after run marco 1 sheet :
enter image description here
enter image description here
This is how I would normally loop through all sheets with an exception:
Sub loop_through_sheets()
Dim ws As Worksheet
For Each ws In Sheets
If ws.Name <> "Mastersheet" Then
'... run the code on ws
Else
'.. do nothing
End If
Next
End Sub
Your code to run on ws might look something like this:
With ws
'auto fit the columns
.Range("A:AC").Columns.AutoFit
'find the last populated cell in column A
Dim lastrow as Long
lastrow=ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'insert the formula
.Range("A8:A" & lastrow).FormulaR1C1 = "=R4C2"
'etc. etc.
End with
of course this is not the cleanest and best solution (see comment "avoid select...."), but leave the code as is it, make a sub for calling it like:
sub callmymacro
Dim ws As Worksheet
For Each ws In Sheets
if ws.Name = "Mastersheet" GoTo notthisone
Sheets(ws).Select
call Macro5
notthisone:
Next
end sub

Selection.Replace in VBA macro

I need to change the code so that
LMX220MA (KIT) becomes X220MA,
LMX220MA becomes X220MA,
LMX220 (KIT) becomes X220MB,
LMX220 becomes X220MB.
Tried removing LMX22 Selection.Replace line and then adding:
Range("H2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],6)"
Selection.Copy
Range("G1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(, 1).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks
Selection.Replace What:="LMX220", Replacement:="X220MB", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("H2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],8)"
Selection.Copy
Range("G1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(, 1).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks
Selection.Replace What:="LMX220MA", Replacement:="X220MA",
LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
and so on.
Original code:
' Insert Model Number_Carrier column
Sheets("Data_Upload").Select
Columns("H:H").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H1").Select
ActiveCell.FormulaR1C1 = "Model Number_Carrier"
' Fill Model Number_Carrier field
Range("H2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],5)"
Selection.Copy
Range("G1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(, 1).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("H:H").Select
Selection.Replace What:="LMX21", Replacement:="X210MA", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="MW41M", Replacement:="_", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="Q710M", Replacement:="Q710MS", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="LMQ61", Replacement:="Q610MA", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="LMQ71", Replacement:="_", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="X410M", Replacement:="X410MK", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="LMX22", Replacement:="X220MB", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A1").Select
It will fill ModelNumber_Carrier cells with what is in the cell in Model column (LMX220 becomes LMX220) and "ModelNumber_Carrier" column becomes "Model" even though ModelNumber_Carrier column coding was left alone.
Returning compile error: end sub error when I change it to this:
Sub MPCSWeeklyReturnReason()
'
' MPCS_Return_Reason Macro
'
' Prevents screen refreshing.
Application.ScreenUpdating = False
' Check if procedure has already run
Dim rCell As String
rCell = ActiveSheet.Range("H1").Text
If InStr(1, rCell, "Model Number_Carrier") Then
Application.ScreenUpdating = True
MsgBox "Macro already run."
Exit Sub
Else
' Combine all worksheets to one for upload
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Data_Upload"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
' Insert Model Number_Carrier column
Sheets("Data_Upload").Select
Columns("H:H").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H1").Select
ActiveCell.FormulaR1C1 = "Model Number_Carrier"
' Fill Model Number_Carrier field
Sub FindReplaceAll()
' This will find and replace text in all sheets
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
Dim fnd1 As Variant
Dim rplc1 As Variant
Dim fnd2 As Variant
Dim rplc2 As Variant
Dim fnd3 As Variant
Dim rplc3 As Variant
'Set the criteria to change here
fnd = "LMX220MA (KIT)"
rplc = "X220MA"
fnd1 = "LMX220MA"
rplc1 = "X220MA"
fnd2 = "LMX220 (KIT)"
rplc2 = "X220MB"
fnd3 = "LMX220"
rplc3 = "X220MB"
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace what:=fnd, Replacement:=rplc, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
sht.Cells.Replace what:=fnd1, Replacement:=rplc1, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
sht.Cells.Replace what:=fnd2, Replacement:=rplc2, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
sht.Cells.Replace what:=fnd3, Replacement:=rplc3, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht
End Sub
' ESN Concantenate Fix
Range("Q2").Select
ActiveCell.FormulaR1C1 = "=TEXT(,RC[-11])"
Selection.Copy
Range("A2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 16).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("R2").Select
ActiveCell.FormulaR1C1 = "=IF(ISERROR(RC[-1]), RC[-12], RC[-1])"
Selection.Copy
Range("Q2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("Q:R").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
' TRIM Reason and SUBReason spaces
Range("Q2").Select
ActiveCell.FormulaR1C1 = "=TRIM(RC[-4])"
Selection.Copy
Range("A2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 16).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Range("M2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("Q:Q").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
' Enables screen refreshing.
Application.ScreenUpdating = True
' Save the Workbook
ActiveWorkbook.Save
End If
End Sub
Here try this. It will go through all of the sheets in your workbook and find and replace all cases with the text you specified. I was unsure if you wanted to have the "(KIT)" included so I left it in, but feel free to adjust as necessary.
Sub FindReplaceAll()
' This will find and replace text in all sheets
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
Dim fnd1 As Variant
Dim rplc1 As Variant
Dim fnd2 As Variant
Dim rplc2 As Variant
Dim fnd3 As Variant
Dim rplc3 As Variant
'Set the criteria to change here
fnd = "LMX220MA (KIT)"
rplc = "X220MA"
fnd1 = "LMX220MA"
rplc1 = "X220MA"
fnd2 = "LMX220 (KIT)"
rplc2 = "X220MB"
fnd3 = "LMX220"
rplc3 = "X220MB"
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace what:=fnd, Replacement:=rplc, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
sht.Cells.Replace what:=fnd1, Replacement:=rplc1, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
sht.Cells.Replace what:=fnd2, Replacement:=rplc2, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
sht.Cells.Replace what:=fnd3, Replacement:=rplc3, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht
End Sub
Took another look at this and you can also do it this way by using arrays. Similar to my other answer with this one if I left in the "(KIT)" that shouldn't have been there or anything just adjust as necessary but the syntax is there.
Sub FindReplaceAll()
Dim sht As Worksheet
Dim fndList As Variant
Dim rplcList As Variant
Dim x As Long
'Set the criteria to change here
fndList = Array("LMX220MA (KIT)", "LMX220MA", "LMX220 (KIT)", "LMX220")
rplcList = Array("X220MA", "X220MA", "X220MB", "X220MB")
'Loop through each item in Array lists
For x = LBound(fndList) To UBound(fndList)
'Loop through each worksheet in ActiveWorkbook
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace What:=fndList(x), Replacement:=rplcList(x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next sht
Next x
End Sub

Converting Word>Excel mail merge to an Excel>Word merge

Good morning,
I have an Excel document that is set up to complete a mail merge. Previously, a ran a script from within the MS Word mail merge template to call the Excel file, connect to it, and pull in the data. I recently found a code example that suggested embedding the code within the Excel document and pointing it to the Word template. This seems to make a lot more sense given my workflow.
This snippet worked within MS Word to reach out and connect to the Excel workbook:
ThisDocument.MailMerge.OpenDataSource Name:= _
ThisDocument.Path & "\" & "REF 1.23.18.xlsm", ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, _
Connection:= _
"Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=reflist.xlsm;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=37;Jet OLEDB:Database Locking " _
, SQLStatement:="SELECT * FROM `REF_LTR$`", SQLStatement1:="", SubType:= _
wdMergeSubTypeAccess
However, when I move the script over into MS Excel to try and connect to the Word template from Excel, this script is failing with a "run time error 4198 - Command Failed":
wdocSource.MailMerge.OpenDataSource _
Name:=strWorkbookName, _
ConfirmConversions:=False, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto, _
Connection:="Data Source=" & strWorkbookName & ";Mode=Read", _
SQLStatement:="SELECT * FROM `REF_LTR$`", SQLStatement1:="", SubType:= _
wdMergeSubTypeAccess
Any suggestions on what my second block of code is missing?
Here is the entire script for reference:
Sub test()
' Delete the first 8 rows which contain the header data
On Error Resume Next
Rows("1:8").Select
Selection.Delete Shift:=xlUp
' Delete the empty spaces in column A, Name
Columns("A:A").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Delete the empty spaces in column B, MRN
Columns("B:B").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Delete the empty spaces in columns D and E, format them as dates
Columns("D:E").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.NumberFormat = "m/d/yyyy"
' Delete the empty spaces in columns F and G
Columns("F:G").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Format AdmitTime as military time
Columns("F:F").Select
Application.CutCopyMode = False
Selection.NumberFormat = "h:mm;#"
Selection.NumberFormat = "hhmm"
' Delete any rows that don't have a name in column A
Columns("A").SpecialCells(xlBlanks).EntireRow.Delete
' Add the column titles
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("1:1").Select
Selection.Font.Bold = True
Selection.Font.Underline = xlUnderlineStyleSingle
Range("A1").Select
ActiveCell.FormulaR1C1 = "Name"
Range("B1").Select
ActiveCell.FormulaR1C1 = "MRN"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Sex"
Range("D1").Select
ActiveCell.FormulaR1C1 = "DOB"
Range("E1").Select
ActiveCell.FormulaR1C1 = "AdmitDate"
Range("F1").Select
ActiveCell.FormulaR1C1 = "AdmitTime"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Category"
Range("H1").Select
ActiveCell.FormulaR1C1 = "ReferHospital"
Range("I1").Select
ActiveCell.FormulaR1C1 = "Complaint"
Range("J1").Select
ActiveCell.FormulaR1C1 = "Description"
Range("K1").Select
ActiveCell.FormulaR1C1 = "Unit"
Range("L1").Select
ActiveCell.FormulaR1C1 = "Disposition"
Range("M1").Select
ActiveCell.FormulaR1C1 = "LOS"
Range("N1").Select
ActiveCell.FormulaR1C1 = "ICD10"
Range("O1").Select
ActiveCell.FormulaR1C1 = "AdmitYear"
Range("P1").Select
ActiveCell.FormulaR1C1 = "AdmitMonth"
Range("Q1").Select
ActiveCell.FormulaR1C1 = "AdmitDay"
Range("R1").Select
ActiveCell.FormulaR1C1 = "GenderPronoun"
Range("A2").Select
' Add the helper columns to pull in the admityear, admitmonth, admitday, and genderpronoun
Range("O2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-14]="""","""",TEXT(RC[-10],""yyyy""))"
Range("O2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-14]="""","""",TEXT(RC[-10],""yyyy""))"
Range("P2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-15]="""","""",TEXT(RC[-11],""mm""))"
Range("Q2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-16]="""","""",TEXT(RC[-12],""dd""))"
Range("R2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-17]="""","""",IF(RC[-15]=""M"",""his"",""her""))"
Range("O2:R2").Select
Selection.Copy
Range("O3:R50").Select
ActiveSheet.Paste
' Find and replace hospital names
Columns("H:H").Select
Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Fort Hamilton Hospital
Columns("H:H").Select
Cells.Replace What:="FortHamilton-HughesMemorialHospital(", Replacement _
:="Fort Hamilton Hospital", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Grandview
Columns("H:H").Select
Cells.Replace What:="GrandviewHospital(OHMontgomery)", Replacement _
:="Grandview Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Greene Memorial Hospital
Columns("H:H").Select
Cells.Replace What:="GreeneMemorialHospital(OHGreene)", Replacement _
:="Greene Memorial Hospital", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Kettering Health Network - Franklin
Columns("H:H").Select
Cells.Replace What:="FRANKLINSPRINGBOROED", Replacement _
:="Kettering Health Network - Franklin", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Kettering Health Network - Huber
Columns("H:H").Select
Cells.Replace What:="HuberHeightsED", Replacement _
:="Kettering Health Network - Huber", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Kettering Health Netowrk - Preble
Columns("H:H").Select
Cells.Replace What:="PrebleCoED", Replacement _
:="Kettering Health Network - Preble", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' McCullough-Hyde Memorial Hospital
Columns("H:H").Select
Cells.Replace What:="McCullough-HydeMemorialHospital(OH", Replacement _
:="McCullough-Hyde Memorial Hospital", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Mercer County Community Hospital
Columns("H:H").Select
Cells.Replace What:="MercerCountyJointTwp.CommunityHospi", Replacement _
:="Mercer County Community Hospital", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Soin Medical Center
Columns("H:H").Select
Cells.Replace What:="SoinMedicalCenter", Replacement _
:="Soin Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Southview Medical Center
Columns("H:H").Select
Cells.Replace What:="SouthviewHospital&FamilyHealthCente", Replacement _
:="Southview Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Springfield Regional Medical Center
Columns("H:H").Select
Cells.Replace What:="CommunityHospitalofSpringfield(OHCl", Replacement _
:="Springfield Regional Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Columns("H:H").Select
Cells.Replace What:="SpringfieldRegionalHosptial", Replacement _
:="Springfield Regional Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Sycamore Medical Center
Columns("H:H").Select
Cells.Replace What:="SycamoreHospital(OHMontgomery)", Replacement _
:="Sycamore Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Upper Valley Medical Center
Columns("H:H").Select
Cells.Replace What:="UpperValleyMedicalCenter", Replacement _
:="Upper Valley Medical Center", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Wilson Memorial Hospital
Columns("H:H").Select
Cells.Replace What:="WilsonHospital(OHShelby)", Replacement _
:="Wilson Memorial Hospital", LookAt:=xlPart, SearchOrder:=xlByRows _
, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
' Select A1 cell
Range("A1").Select
' This macro does the following:
' Runs a mail merge and pulls fields to create follow-up letter drafts
' Creates individual Word documents and then saves them in the appropriate folder for the hospital name
'
Dim Name As String
Dim MRN As String
Dim Sex As String
Dim DOB As String
Dim AdmitDate As String
Dim AdmitTime As String
Dim Category As String
Dim ReferHospital As String
Dim Complaint As String
Dim Description As String
Dim Unit As String
Dim Disposition As String
Dim LOS As String
Dim ICD10 As String
Dim AdmitYear As String
Dim AdmitMonth As String
Dim AdmitDay As String
Dim GenderPronoun As String
Dim wd As Object
Dim wdocSource As Object
Dim strWorkbookName As String
'Check to see if the folder exists, and if not, create it
Dim fdObj As Object
Set fdObj = CreateObject("Scripting.FileSystemObject")
If fdObj.FolderExists(ThisDocument.Path & ReferHospital) Then
Else
fdObj.CreateFolder (ThisDocument.Path & ReferHospital)
End If
' NEW!!!!
' Connect to the sign-in spreadsheet which is the data source
On Error Resume Next
Set wd = GetObject(, "Word.Application")
If wd Is Nothing Then
Set wd = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdocSource = wd.Documents.Open("C:\Users\k113997\Desktop\1macrotest\Trauma Referral Template.docm")
strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
wdocSource.MailMerge.MainDocumentType = wdFormLetters
wdocSource.MailMerge.CreateDataSource _
Name:=strWorkbookName, _
SQLStatement:="SELECT * FROM `REF_LTR$`", _
SubType:=wdMergeSubTypeAccess
' Obtaines the number of records from the mail merge
For i = 1 To ThisDocument.MailMerge.DataSource.RecordCount
' Counts the lines in the excel file
With wdocSource.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
' Ignore any records where Name is blank, as in empty data fields
If Trim(.DataFields("Name")) = "" Then Exit For
' Pull in the datafields from the sign-in spreadsheet
Name = .DataFields("Name").Value
MRN = .DataFields("MRN").Value
Sex = .DataFields("Sex").Value
DOB = .DataFields("DOB").Value
AdmitDate = .DataFields("AdmitDate").Value
AdmitTime = .DataFields("AdmitTime").Value
Category = .DataFields("Category").Value
ReferHospital = .DataFields("ReferHospital").Value
Complaint = .DataFields("Complaint").Value
Description = .DataFields("Description").Value
Unit = .DataFields("Unit").Value
Disposition = .DataFields("Disposition").Value
LOS = .DataFields("LOS").Value
ICD10 = .DataFields("ICD10").Value
AdmitYear = .DataFields("AdmitYear").Value
AdmitMonth = .DataFields("AdmitMonth").Value
AdmitDay = .DataFields("AdmitDay").Value
GenderPronoun = .DataFields("GenderPronoun").Value
End With
' Execute the mail merge
.Execute Pause:=False
End With
' Set the directory path for the output files to be the same as the directory for this document
docpath = ThisDocument.Path & "\" & ReferHospital
' Set the document naming convention with the course year, course month, course day, department, and course name
docname = AdmitYear + "-" + AdmitMonth + "-" + AdmitDay + " " + MRN
' Check and make sure that docname does not have any special characters that will mess up the filename, and if found, remove them
docnameclean = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(docname, "<", ""), ">", ""), ":", ""), "/", ""), "\", ""), "?", ""), "&", ""), "*", ""), ",", ""), ".", "")
' Change the focus to the active directory where the files are stored
ChDrive ActiveDocument.Path
' ChangeFileOpenDirectory _
' ".\"
ActiveDocument.SaveAs2 Filename:=docpath & "\" & docnameclean + ".docx", _
FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, CompatibilityMode:=15
' Close the active document
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
' Switch to the next document in the mail merge
Next i
wd.Visible = True
wdocSource.Close SaveChanges:=False
Set wdocSource = Nothing
Set wd = Nothing
End Sub
Thanks,
Chris
When you open a Word document or attach a Template through VBA, the mail merge data source (if any) is not attached to the document for security reasons.
Try replacing:
wdocSource.MailMerge.OpenDataSource(...)
To:
wdocSource.MailMerge.CreateDataSource(...)
using the same method parameters but do not set the Connection parameter as it will be created for you.
wdocSource.MailMerge.CreateDataSource _
Name:=strWorkbookName, _
SQLStatement:="SELECT * FROM `REF_LTR$`", _
SubType:= wdMergeSubTypeAccess

Find and replace text causes error in VBA Code

I have a macro created by Ron de Bruin, which I have modified to replace text in the files I open.
I use the code to open several files, grab the data, and switch the filtered column text "To Be Paid" to "Paid".
The problem I am having, is if the text is not found, (No records with this filter) the codes stops and does not complete.
Is there code that I can use to continue/skip this file and move on to the next one?
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
ActiveSheet.ListObjects("List1").Range.AutoFilter Field:=10, Criteria1:= _
"<>"
Columns("J:J").Select
Selection.Replace What:="to be paid", Replacement:="paid", LookAt:=xlPart _
, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'Remove the AutoFilter
.AutoFilterMode = False
End With
End If
'Close the workbook without saving
mybook.Close savechanges:=True
You can Cheack if there are any Cells with "to be Paid" and do the Replacement if he had found one.
Dim FoundRange As Range
ActiveSheet.ListObjects("List1").Range.AutoFilter Field:=10, Criteria1:= _
"<>"
Columns("J:J").Select
Set FoundRange = Selection.Find(what:="to be paid", LookIn:=xlFormulas, lookat:=xlWhole)
if Not FoundRange is Nothing then
Selection.Replace What:="to be paid", Replacement:="paid", LookAt:=xlPart _
, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End if
'Remove the AutoFilter
.AutoFilterMode = False
End With
End If
'Close the workbook without saving
mybook.Close savechanges:=True

Excel - Copy adjacent data value to another sheet based on certain text, till end of sheet

So I have two excel documents.
One to take data from (RESULT.xlsm).
Another to insert data into (Summary.xls).
What I want is the adjacent cell values next to the hightlighted names to get inserted into Summary.xls under the respective columns. So I tried recording a macro but what happens is only the first record gets inserted.
Since only two links are allowed for me, i put it all in one picture:
http://i50.tinypic.com/9veihl.png
Note: There are multiple records in RESULT.xlsm and the screenshot shows just one.
I would like help on how I can extract data from all the set of records and insert in Summary.xlsx
Here's the recorded macro code:
Sub Summ()
Workbooks.Open Filename:="Summary.xlsx"
Windows.Arrange ArrangeStyle:=xlVertical
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Air System Name", After:=ActiveCell, LookIn:=xlFormulas _
, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("B10").Select
Selection.Copy
Windows("Summary.xlsx").Activate
Range("A5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Floor Area", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("B14").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("B5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Total coil load", After:=ActiveCell, LookIn:=xlFormulas _
, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("B27").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("C5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Sensible coil load", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
Range("B28").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("D5").Select
ActiveSheet.Paste
Windows("RESULT.xlsm").Activate
Cells.Find(What:="Max block L/s", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("B30").Select
Application.CutCopyMode = False
Selection.Copy
Windows("Summary.xlsx").Activate
Range("E5").Select
ActiveSheet.Paste
Range("A6").Select
End Sub
I've also attached the excel files at mediafire:
Excel files
Please do help.
Thanks alot:)
So I looked up at alot of resources and tried to follow what #Tim Williams told me to and stumbled across this page (the last part): https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/text-functions/column-sets-to-rows
They had a solution almost close to my problem, so I made a few modifications and I'm done:D
Note: This is within the same document, different sheets.
The code of it:
Dim LR As Long, NR As Long, Rw As Long
Dim wsData As Worksheet, wsOUT As Worksheet
Dim HdrCol As Range, Hdr As String, strRESET As String
Set wsData = Sheets("Sheet1") 'source data
Set wsOUT = Sheets("Sheet2") 'output sheet
strRESET = "    Air System Name " 'this value will cause the record row to increment
LR = wsData.Range("A" & Rows.Count).End(xlUp).Row
'end of incoming data
Set HdrCol = wsOUT.Range("1:1").Find(strRESET, _
LookIn:=xlValues, LookAt:=xlWhole) 'find the reset category column
If HdrCol Is Nothing Then
MsgBox "The key string '" & strRESET & _
"' could not be found on the output sheet."
Exit Sub
End If
NR = wsOUT.Cells(Rows.Count, HdrCol.Column) _
.End(xlUp).Row 'current output end of data
Set HdrCol = Nothing
On Error Resume Next
For Rw = 1 To LR
Hdr = wsData.Range("A" & Rw).Value
If (Hdr = "    Air System Name ") Then
NR = NR + 1
End If
If Hdr <> "" Then
Set HdrCol = wsOUT.Range("1:1").Find(Hdr, _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not HdrCol Is Nothing Then
wsOUT.Cells(NR, HdrCol.Column).Value _
= wsData.Range("B" & Rw).Value
Set HdrCol = Nothing
End If
End If
Next Rw
The only little problem is the space. In my excel document, my report has trailing and leading spaces, and this doesn't match with my sheet2 columns headers, I kind of temporarily fixed it, since I looked around and couldn't find a way to automatically trim all the space from the whole column.
So that's it:)

Resources