2 Replies - 1318 Views - Last Post: 20 April 2010 - 04:37 AM Rate Topic: -----

#1 guyfromri   User is offline

  • D.I.C Addict

Reputation: 46
  • View blog
  • Posts: 836
  • Joined: 16-September 09

Using Access to Call an XLS, run a macro and export

Posted 19 April 2010 - 11:46 AM

So I have an access program that performs a lot of operations on a file that I import. I do have a macro I wrote in excel to do a few things that's pretty efficient and I would like to be able to incorporate into my program. What I would have to do is;

Export my table as text (not a problem)
open an excel wb (not a problem)
import my text to excel as text (I can do this in excel but I'm not quite sure how via access)
call a macro that I have saved in the wb ( is this possible)
export from excel as text (again, I can do this in excel, is it possible to do through access)
import back to access to complete program (not a problem)

this is my code...everything that's here works, I don't quite know where to start with the above..THANKS IN ADVANCE!


ACCESS
Option Compare Database
Option Explicit


Dim IntLastSlash As Integer
Dim IntSlashHold As Integer
Dim SelFile As String
Dim InitDir As String
Dim sInputFile As String
Dim sOPFile As String
Dim sOPRec As String
Dim ProName As String
Dim LCount As Long
Dim LDone As Long
Dim rsMn As Recordset
Dim sChk As String
Dim sChk2 As String
Dim sDate As String
Dim sYr As String
Dim D As String
Dim M As String
Dim Y As String
Dim Demo As ctdemodata
Dim sProp As String
Dim bLng As Boolean
Dim sLng As String
Dim HalfMRN As Long
Dim DivMRN As Long
Dim bFixLen As Boolean


Private Sub Check13_Click()

If Check13.Value = True Then
    Toggle24.Enabled = True
    Toggle25.Enabled = True
End If

If Check13.Value = False Then
    Toggle24.Enabled = False
    Toggle25.Enabled = False
End If


End Sub

Private Sub Check4_Click()

If Check4.Value = True Then
    Toggle22.Enabled = True
    Toggle23.Enabled = True
End If

If Check4.Value = False Then
    Toggle22.Enabled = False
    Toggle23.Enabled = False
End If


End Sub

Private Sub Toggle22_Click()

If Toggle22.Value = True Then Toggle23.Value = False
If Toggle23.Value = True Then Toggle22.Value = False

End Sub

Private Sub Toggle23_Click()

If Toggle23.Value = True Then Toggle22.Value = False
If Toggle22.Value = True Then Toggle23.Value = False

End Sub

'(((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((  ~~  END FORM CONTROLS  ~~  )))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))


Private Sub Command10_Click()

'Check2 is permanet because the output function cleans automatically

Set rsMn = CurrentDb.OpenRecordset("Main_Demo")
Set Demo = New ctdemodata


ProName = InputBox("Please enter the provider name", "Pro Name", "Here!")
    If ProName = "" Then End
    If ProName = "Here!" Then End
    
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    If .Show = False Then End
    SelectedFile = .SelectedItems(1)
End With

IntLastSlash = InStr(1, SelectedFile, "\")
Do Until IntLastSlash = 0
IntLastSlash = InStr((IntLastSlash + 1), SelectedFile, "\")
If IntLastSlash <> 0 Then
IntSlashHold = IntLastSlash
End If
Loop

' remember the selected directory for subsequent dialog boxes...
InitDir = Mid(SelectedFile, 1, (IntSlashHold - 1))
InputFile = Mid(SelectedFile, (IntSlashHold + 1))
OPFile = InitDir & "\" & ProName & "_CtReady.csv"

DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE * from Main_Demo"
DoCmd.SetWarnings True

'Import File
DoCmd.TransferText acImportDelim, "MainDemoSpec", "Main_Demo", SelectedFile, False

'Do all fixes on export
rsMn.MoveFirst

'############################################################################################################
                                                                                                                   'CHECK FOR DUPLICATES
                                                                                                                   
                                                                                                                                                                                                                                  
rsMn.MoveFirst
    
    Do Until rsMn.EOF
    
        MRN = rsMn.Fields("MRN")
        SSN = rsMn.Fields("SSN")
        FName = rsMn.Fields("FName")
        
            Do Until rsMn.EOF
            
    Loop
        
'############################################################################################################
                                                                                                                'CHECK LENGTH OF FIELDS
                                                                                    'Check length of all fields and fix or report based on toggle buttons

If Check4.Value = True Then Call CheckLen

'############################################################################################################
                                                                                                                        'FIX DATES OF BIRTH
rsMn.MoveFirst

Open OPFile For Output As #52

    Do Until rsMn.EOF
                                                                                                                                    
            ''''''''''''''''''''''''''''''''''''''''''''''
            'Possible Formats _
                6    MMDDYY _
                8    MMDDYYYY _
                8    YYYYMMDD _
                6    M/D/YY _
                7    MM/D/YY _
                7    M/DD/YY _
                Includes time after format
              ''''''''''''''''''''''''''''''''''''''''''''''
    If Len(rsMn.Fields("DOB")) = 6 Then 'MMDDYY or M/D/YY
    
        sChk = Mid(rsMn.Fields("DOB"), 2, 1)
            
            If sChk = Chr(47) Then 'M/D/YY
                M = Left(rsMn.Fields("DOB"), 1)
                D = Mid(rsMn.Fields("DOB"), 3, 1)
                Y = Right(rsMn.Fields("DOB"), 2)
                
                If Y <= 10 Then
                    sYr = "20" & Y
                Else
                    sYr = "19" & Y
                End If
                
                sDate = "0" & M & "/" & "0" & D & "/" & sYr
                
            Else 'MMDDYY
                
                M = Left(rsMn.Fields("DOB"), 2)
                D = Mid(rsMn.Fields("DOB"), 3, 2)
                Y = Right(rsMn.Fields("DOB"), 2)
                
                If Y <= 10 Then
                    sYr = "20" & Y
                Else
                    sYr = "19" & Y
                End If
                
                sDate = "0" & M & "/" & "0" & D & "/" & sYr
                
            End If
            
    End If
                
    If Len(rsMn.Fields("DOB")) = 7 Then
        
        sChk = Mid(rsMn.Fields("DOB"), 2, 1)
            
            If sChk = Chr(47) Then 'M/DD/YY
                M = Left(rsMn.Fields("DOB"), 1)
                D = Mid(rsMn.Fields("DOB"), 3, 2)
                Y = Right(rsMn.Fields("DOB"), 2)
                
                If Y <= 10 Then
                    sYr = "20" & Y
                Else
                    sYr = "19" & Y
                End If
                
                sDate = "0" & M & "/" & D & "/" & sYr
                
            Else 'MM/DD/YY
                
                M = Left(rsMn.Fields("DOB"), 2)
                D = Mid(rsMn.Fields("DOB"), 4, 2)
                Y = Right(rsMn.Fields("DOB"), 2)
                
                If Y <= 10 Then
                    sYr = "20" & Y
                Else
                    sYr = "19" & Y
                End If
                
                sDate = M & "/" & "0" & D & "/" & sYr
                
            End If
            
    End If
    
    If Len(rsMn.Fields("DOB")) = 8 Then
        
        sChk = Left(rsMn.Fields("DOB"), 2)
            
            If sChk > 12 Then 'YYYYMMDD
                M = Mid(rsMn.Fields("DOB"), 5, 2)
                D = Right(rsMn.Fields("DOB"), 2)
                Y = Left(rsMn.Fields("DOB"), 4)
                
                sDate = M & "/" & D & "/" & Y
                
            ElseIf sChk <= 12 Then 'Fixes MMDDYYYY but double checks to make sure its not M/D/YYYY
                
                sChk2 = Mid(rsMn.Fields("DOB"), 2, 1)
                
                    If Not sChk2 = Chr(47) Then 'Isn't "/" so we assume it's the format we want
                        M = Left(rsMn.Fields("DOB"), 2)
                        D = Mid(rsMn.Fields("DOB"), 3, 2)
                        Y = Right(rsMn.Fields("DOB"), 4)
                        
                        sDate = M & "/" & D & "/" & Y
                    
                    End If
            
            End If
            
    End If
'############################################################################################################

                                                                                                                          'APPEND COPAY WITH CP=
                                                                                                    
    If Check6.Value = True Then Call CPFix
        
'############################################################################################################
                                                                                                                           'CREATE INSURANCE ID'S
                                                                                                    
    If Check11.Value = True Then
            
        If rsMn.Fields("Ins1ID") = "" Then rsMn.Fields("Ins1ID") = rsMn.Fields("Ins1Name")
        If rsMn.Fields("Ins2ID") = "" Then rsMn.Fields("Ins2ID") = rsMn.Fields("Ins2Name")
        If rsMn.Fields("Ins3ID") = "" Then rsMn.Fields("Ins3ID") = rsMn.Fields("Ins3Name")
            
    End If

'############################################################################################################
                                                                                                        'EXPORT THE FILE AND RUN THE FINAL FIXERS
                                                                                                                  

If rsMn.Fields("SSN") > "" Then
    If Len(rsMn.Fields("SSN")) > 9 Then Demo.SSN = Replace(rsMn.Fields("SSN"), Chr(45), "")
    If Len(rsMn.Fields("SSN")) = 8 Then Demo.SSN = "0" & rsMn.Fields("SSN")
    If Len(rsMn.Fields("SSN")) = 7 Then Demo.SSN = "00" & rsMn.Fields("SSN")
End If


'Left off here...mrn's are done and ssn's are done. leave a blng marker at each field and if it's tripped then 'if toggle23.value=true call exportreport

If rsMn.Fields("FName") > "" Then Demo.FName = rsMn.Fields("FName")
If rsMn.Fields("MName") > "" Then Demo.mame = rsMn.Fields("MName")
If rsMn.Fields("LName") > "" Then Demo.LName = rsMn.Fields("LName")
If rsMn.Fields("DOB") > "" Then Demo.DOB = sDate
If rsMn.Fields("Sex") > "" Then Demo.SSN = rsMn.Fields("Sex")
If rsMn.Fields("Email") > "" Then Demo.Email = rsMn.Fields("Email")
If rsMn.Fields("Add1") > "" Then Demo.Addy1 = rsMn.Fields("Add1")
If rsMn.Fields("Add2") > "" Then Demo.Addy2 = rsMn.Fields("Add2")
If rsMn.Fields("City") > "" Then Demo.City = rsMn.Fields("City")
If rsMn.Fields("State") > "" Then Demo.State = rsMn.Fields("State")
If rsMn.Fields("Zip") > "" Then Demo.Zip = rsMn.Fields("Zip")
If rsMn.Fields("Country") > "" Then Demo.Country = rsMn.Fields("Country")
If rsMn.Fields("HomePhone") > "" Then Demo.Phone = rsMn.Fields("HomePhone")
If rsMn.Fields("GuarMRN") > "" Then Demo.GuarMRN = rsMn.Fields("GuarMRN")
If rsMn.Fields("GuarRel") > "" Then Demo.GuarRela = rsMn.Fields("GuarRel")
If rsMn.Fields("EmpName") > "" Then Demo.EmpName = rsMn.Fields("EmpName")
If rsMn.Fields("EmpAdd1") > "" Then Demo.EmpAddy1 = rsMn.Fields("EmpAdd1")
If rsMn.Fields("EmpAdd2") > "" Then Demo.EmpAddy2 = rsMn.Fields("EmpAdd2")
If rsMn.Fields("EmpCity") > "" Then Demo.EmpCity = rsMn.Fields("EmpCity")
If rsMn.Fields("EmpState") > "" Then Demo.EmpState = rsMn.Fields("EmpState")
If rsMn.Fields("EmpZip") > "" Then Demo.EmpZip = rsMn.Fields("EmpZip")
If rsMn.Fields("EmpCountry") > "" Then Demo.EmpCountry = rsMn.Fields("EmpCountry")
If rsMn.Fields("EmpPhone") > "" Then Demo.EmpPhone = rsMn.Fields("EmpPhone")
If rsMn.Fields("EmpExt") > "" Then Demo.EmpExt = rsMn.Fields("EmpExt")
If rsMn.Fields("MarStat") > "" Then Demo.MarStat = rsMn.Fields("MarStat")
If rsMn.Fields("GPro") > "" Then Demo.GPro = rsMn.Fields("GPro")
If rsMn.Fields("GNPI") > "" Then Demo.GProNPI = rsMn.Fields("GNPI")
If rsMn.Fields("Notes") > "" Then Demo.PatNotes = rsMn.Fields("Notes")
If rsMn.Fields("Group") > "" Then Demo.PatGroup = rsMn.Fields("Group")
If rsMn.Fields("Ins1ID") > "" Then Demo.Ins1ID = rsMn.Fields("Ins1ID")
If rsMn.Fields("Ins1Name") > "" Then Demo.Ins1Name = rsMn.Fields("Ins1Name")
If rsMn.Fields("Ins1Add") > "" Then Demo.Ins1Addy = rsMn.Fields("Ins1Add")
If rsMn.Fields("Ins1Pol") > "" Then Demo.Ins1PolNum = rsMn.Fields("Ins1Pol")
If rsMn.Fields("Ins1CP") > "" Then Demo.Ins1CoPay = rsMn.Fields("Ins1CP")
If rsMn.Fields("Ins1Group") > "" Then Demo.Ins1GroupNum = rsMn.Fields("Ins1Group")
If rsMn.Fields("Ins1SubMRN") > "" Then Demo.Ins1SubMRN = rsMn.Fields("Ins1SubMRN")
If rsMn.Fields("Ins1SubRel") > "" Then Demo.Ins1SubRela = rsMn.Fields("Ins1SubRel")
If rsMn.Fields("Ins2ID") > "" Then Demo.Ins2ID = rsMn.Fields("Ins2ID")
If rsMn.Fields("Ins2Name") > "" Then Demo.Ins2Name = rsMn.Fields("Ins2Name")
If rsMn.Fields("Ins2Add") > "" Then Demo.Ins2Addy = rsMn.Fields("Ins2Add")
If rsMn.Fields("Ins2Pol") > "" Then Demo.Ins2PolNum = rsMn.Fields("Ins2Pol")
If rsMn.Fields("Ins2CP") > "" Then Demo.Ins2CoPay = rsMn.Fields("Ins2CP")
If rsMn.Fields("Ins2Group") > "" Then Demo.Ins2GroupNum = rsMn.Fields("Ins2Group")
If rsMn.Fields("Ins2SubMRN") > "" Then Demo.Ins2SubMRN = rsMn.Fields("Ins2SubMRN")
If rsMn.Fields("Ins2SubRel") > "" Then Demo.Ins2SubRela = rsMn.Fields("Ins2SubRel")
If rsMn.Fields("Ins3ID") > "" Then Demo.Ins3ID = rsMn.Fields("Ins3ID")
If rsMn.Fields("Ins3Name") > "" Then Demo.Ins3Name = rsMn.Fields("Ins3Name")
If rsMn.Fields("Ins3Add") > "" Then Demo.Ins3Addy = rsMn.Fields("Ins3Add")
If rsMn.Fields("Ins3Pol") > "" Then Demo.Ins3PolNum = rsMn.Fields("Ins3Pol")
If rsMn.Fields("Ins3CP") > "" Then Demo.Ins3CoPay = rsMn.Fields("Ins3CP")
If rsMn.Fields("Ins3Group") > "" Then Demo.Ins3GroupNum = rsMn.Fields("Ins3Group")
If rsMn.Fields("Ins3SubMRN") > "" Then Demo.Ins3SubMRN = rsMn.Fields("Ins3SubMRN")
If rsMn.Fields("Ins3SubRel") > "" Then Demo.Ins3SubRela = rsMn.Fields("Ins3SubRel")
If rsMn.Fields("GenData") > "" Then Demo.GenData = rsMn.Fields("GenData")
If rsMn.Fields("RPro") > "" Then Demo.RefPro = rsMn.Fields("RPro")
If rsMn.Fields("RNPI") > "" Then Demo.RefProNPI = rsMn.Fields("RNPI")
If rsMn.Fields("RNPI") > "" Then Demo.RefProNPI = rsMn.Fields("RNPI")
If rsMn.Fields("Diag1Code") > "" Then Demo.Diag1Code = rsMn.Fields("Diag1Code")
If rsMn.Fields("Diag1Date") > "" Then Demo.Diag1Date = rsMn.Fields("Diag1Date")
If rsMn.Fields("Diag1Notes") > "" Then Demo.Diag1Note = rsMn.Fields("Diag1Notes")
If rsMn.Fields("Diag2Code") > "" Then Demo.Diag2Code = rsMn.Fields("Diag2Code")
If rsMn.Fields("Diag2Date") > "" Then Demo.Diag2Date = rsMn.Fields("Diag2Date")
If rsMn.Fields("Diag2Notes") > "" Then Demo.Diag2Note = rsMn.Fields("Diag2Notes")
If rsMn.Fields("Diag3Code") > "" Then Demo.Diag3Code = rsMn.Fields("Diag3Code")
If rsMn.Fields("Diag3Date") > "" Then Demo.Diag3Date = rsMn.Fields("Diag3Date")
If rsMn.Fields("Diag3Notes") > "" Then Demo.Diag3Note = rsMn.Fields("Diag3Notes")

End Sub


Sub CheckLen()

        Do Until rsMn.EOF
            
            If rsMn.Fields("MRN") > "" Then
                If Len(rsMn.Fields("MRN")) > 10 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("FName") > "" Then
                If Len(rsMn.Fields("FName")) > 25 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("MName") > "" Then
                If Len(rsMn.Fields("MName")) > 25 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("LName") > "" Then
                If Len(rsMn.Fields("LName")) > 25 Then
                    bLng = True
                    GoTo LenOps
            End If

            If rsMn.Fields("Sex") > "" Then
                If Len(rsMn.Fields("Sex")) > 10 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Email") > "" Then
                If Len(rsMn.Fields("Email")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Add1") > "" Then
                If Len(rsMn.Fields("Add1")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            If rsMn.Fields("Add2") > "" Then
                If Len(rsMn.Fields("Add2")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("City") > "" Then
                If Len(rsMn.Fields("City")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("State") > "" Then
                If Len(rsMn.Fields("State")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Zip") > "" Then
                If Len(rsMn.Fields("Zip")) > 10 Then
                    bLng = True
                    GoTo LenOps
            End If

            If rsMn.Fields("Country") > "" Then
                If Len(rsMn.Fields("Country")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("GuarMRN") > "" Then
                If Len(rsMn.Fields("GuarMRN")) > 10 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("GuarRel") > "" Then
                If Len(rsMn.Fields("GuarRel")) > 20 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("EmpName") > "" Then
                If Len(rsMn.Fields("EmpName")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("EmpAdd1") > "" Then
                If Len(rsMn.Fields("EmpAdd1")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("EmpAdd2") > "" Then
                If Len(rsMn.Fields("EmpAdd2")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("EmpCity") > "" Then
                If Len(rsMn.Fields("EmpCity")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("EmpState") > "" Then
                If Len(rsMn.Fields("EmpState")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If

            If rsMn.Fields("EmpZip") > "" Then
                If Len(rsMn.Fields("EmpZip")) > 10 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("EmpCountry") > "" Then
                If Len(rsMn.Fields("EmpCountry")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("EmpPhone") > "" Then
                If Len(rsMn.Fields("EmpPhone")) > 10 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("EmpExt") > "" Then
                If Len(rsMn.Fields("EmpExt")) > 10 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("MarStat") > "" Then
                If Len(rsMn.Fields("MarStat")) > 20 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("GPro") > "" Then
                If Len(rsMn.Fields("GPro")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("GNPI") > "" Then
                If Len(rsMn.Fields("GNPI")) > 25 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Notes") > "" Then
                If Len(rsMn.Fields("Notes")) > 250 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Group") > "" Then
                If Len(rsMn.Fields("Group")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If

            If rsMn.Fields("Ins1ID") > "" Then
                If Len(rsMn.Fields("Ins1ID")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins1Name") > "" Then
                If Len(rsMn.Fields("Ins1Name")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins1Add") > "" Then
                If Len(rsMn.Fields("Ins1Add")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins1Pol") > "" Then
                If Len(rsMn.Fields("Ins1Pol")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins1CP") > "" Then
                If Len(rsMn.Fields("Ins1CP")) > 25 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins1Group") > "" Then
                If Len(rsMn.Fields("Ins1Group")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins1SubMRN") > "" Then
                If Len(rsMn.Fields("Ins1SubMRN")) > 10 Then
                    bLng = True
                    GoTo LenOps
            End If

            If rsMn.Fields("Ins1SubRel") > "" Then
                If Len(rsMn.Fields("Ins1SubRel")) > 20 Then
                    bLng = True
                    GoTo LenOps
            End If
           
            If rsMn.Fields("Ins2ID") > "" Then
                If Len(rsMn.Fields("Ins2ID")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins2Name") > "" Then
                If Len(rsMn.Fields("Ins2Name")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins2Add") > "" Then
                If Len(rsMn.Fields("Ins2Add")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins2Pol") > "" Then
                If Len(rsMn.Fields("Ins2Pol")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins2CP") > "" Then
                If Len(rsMn.Fields("Ins2CP")) > 25 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins2Group") > "" Then
                If Len(rsMn.Fields("Ins2Group")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins2SubMRN") > "" Then
                If Len(rsMn.Fields("Ins2SubMRN")) > 10 Then
                    bLng = True
                    GoTo LenOps
            End If

            If rsMn.Fields("Ins2SubRel") > "" Then
                If Len(rsMn.Fields("Ins2SubRel")) > 20 Then
                    bLng = True
                    GoTo LenOps
            End If
             
            If rsMn.Fields("Ins3ID") > "" Then
                If Len(rsMn.Fields("Ins3ID")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins3Name") > "" Then
                If Len(rsMn.Fields("Ins3Name")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins3Add") > "" Then
                If Len(rsMn.Fields("Ins3Add")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins3Pol") > "" Then
                If Len(rsMn.Fields("Ins3Pol")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins3CP") > "" Then
                If Len(rsMn.Fields("Ins3CP")) > 25 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins3Group") > "" Then
                If Len(rsMn.Fields("Ins3Group")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("Ins3SubMRN") > "" Then
                If Len(rsMn.Fields("Ins3SubMRN")) > 10 Then
                    bLng = True
                    GoTo LenOps
            End If

            If rsMn.Fields("Ins3SubRel") > "" Then
                If Len(rsMn.Fields("Ins3SubRel")) > 20 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("RPro") > "" Then
                If Len(rsMn.Fields("RPro")) > 50 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            If rsMn.Fields("RNPI") > "" Then
                If Len(rsMn.Fields("RNPI")) > 25 Then
                    bLng = True
                    GoTo LenOps
            End If
            
            rsMn.MoveNext
        
        Loop
        
End If
                                                                                                                        
                        'We check all field lengths before moving to the export because if the option to export to file is selected, we don't want to output a file that isn't CT ready
                                                                                                                        
LenOps:
                                
                If bLng = True Then
                    
                    rsMn.MoveFirst
                        
                Do Until rsMn.EOF
                            
                            sLng = MsgBox("You have chart numbers that are too long to be imported to CareTracker!" & vbCrLf & vbCrLf & "PRESS YES if you want to stop this program and export these to a report to fix manually." & _
                                                    vbCrLf & vbCrLf & "PRESS NO if you want to let this program fix them for you." & vbCrLf & vbCrLf & "(If you have them exported you will have to fix them in your source file before " & _
                                                    "running this program again. The export is used as a reference and will not repair your source file.", vbYesNo + vbCritical, "Chart Numbers TOO LONG")
                                                    
                                If sLng = vbYes Then bFixLen = True 'Fix the MRN's by removing the center of chars..keep first 5 and last 5 (best odds of keeping unique numbers -- do this on export
                                If sLng = vbNo Then Call LenReport 'Export MRN's, Names and DOB's
                       
                       rsMn.MoveNext
                       
                Loop
                       
End Sub

Sub CPFix()
        
        If rsMn.Fields("Ins1CP") > "" Then
            If Not Left(rsMn.Fields("Ins1CP"), 3) = "CP=" Then
                rsMn.Fields("Ins1CP") = "CP=" & rsMn.Fields("Ins1CP")
            End If
        End If
        
        If Not Left(rsMn.Fields("Ins2CP"), 3) = "CP=" Then
                rsMn.Fields("Ins2CP") = "CP=" & rsMn.Fields("Ins2CP")
            End If
        End If
        
        If Not Left(rsMn.Fields("Ins3CP"), 3) = "CP=" Then
                rsMn.Fields("Ins3CP") = "CP=" & rsMn.Fields("Ins3CP")
            End If
        End If
    
End Sub

Sub LenFixer()

End Sub

Sub LenReport()

    

End Sub

'TODO

'1. Write LenFixer
'2. Write LenReport
'3. Write Duplicate Checker **((To do this, select field and value then compare with DoCmd.FindRecord "VALUE", acAnywhere, False, acSearchAll, True, acCurrent))**
'3. Complete File Combiner



Excel Macro
'% Jimmys version -- LAST UPDATED:12/17/2009 %'
'<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
'< <><><><><><><>THIS IS THE VERSION FOR MY COMPUTER<><><><><><><>  >'
'<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

'                      CURRENTLY THIS MACRO CAN DO THE FOLLOWING

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~DEMOGRAPHIC~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    'CHECK LENGTH OF INS NAME FIELDS
    'CHECK LENGTH OF INS ADDY FIELDS
    'CHECK LENGTH OF NOTES FIELD
        'IF BAD NOTE FOUND, OPTION TO DELETE OR HILITE CELLS IN GREEN
        'WITH CHAR'S OVER 250 IN RED/BOLD
    'CHECK FOR COPAYS AND APPEND W/CP=
    'CHECK FOR QUOTES IN WHOLE FILE
    'SELECT ALL COLUMNS AND ROWS WITH OUT THE NEED OF THE OPERATOR
    'CHECK FOR DUPLICATES
        'IF DUPS FOUND, GIVE OPTION TO DELETE OR REMOVE AND
        'CREATE NEW REPORT WITH ROWS
    'FIX SSN, REMOVE BAD CHARACTERS AND INSERT LEADING 0'S
    'FIX PHONES(HOME & WORK), REMOVE BAD CHARS
    'FIX ZIP CODES(HOME & WORK), REMOVE BAD CHARS, INSERT LEADING 0'S
    'REMOVE SPACES AND PERIODS FROM INS ADDY'S. (EASIER MAPPING)
    'DELETE HEADER ROW
    'FIX DOB
    'SELECT LOCATION OF OUTPUT FILE WITH A FOLDER PICKER(NO TYPING)
    'NAME OUTPUT FILE, NO NEED TO TYPE .CSV
    'OUTPUT FILE IN COMMA DELIMITED W/ QUOTES
    
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~APPOINTMENT~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    'FIX DATE (MAY OR MAY NOT WORK DEPENDING ON TEXT FORMAT)
    'FIX TIME
    'CHECK LENGTH OF NOTES FIELD & DELETE OR HI-LITE BAD CHAR'S OVER AMOUNT
    'CHECK LENGTH OF COMPLAINTS FIELD & DELETE OR HI-LITE BAD CHAR'S OVER AMOUNT
    'CHECK LENGTH OF PROVIDER NAME & ID FIELDS & DELETE OR HI-LITE BAD CHAR'S OVER AMOUNT
    'CHECK LENGHT OF APPT TYPE NAME & ID FIELDS & DELETE OR HI-LITE BAD CHAR'S OVER AMOUNT
    'CHECK LENGTH OF GROUP NAME & ID FIELDS & DELETE OR HI-LITE BAD CHAR'S OVER AMOUNT
    'CHECK LENGTH OF LOCATION NAME & ID FIELDS & DELETE OR HI-LITE BAD CHAR'S OVER AMOUNT
    'SELECT LOCATION OF OUTPUT FILE WITH A FOLDER PICKER(NO TYPING)
    'NAME OUTPUT FILE, NO NEED TO TYPE .CSV
    'OUTPUT FILE IN COMMA DELIMITED W/ QUOTES
Sub A1_J_XLS2CSV_W_OPTIONS()
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Dim DestFile As String
  Dim FileNum As Long
  Dim ColumnCount As Long
  Dim RowCount As Long
  Dim NumCols As Long                          'THESE ARE THE
  Dim filenam As String
  Dim Hrow As String
  Dim eA_FixAppts As String
  Dim eD_FixDemos As String
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'THIS IS THE NEW STEP ONE WHICH WILL BE ASKING IF THERE IS A HEADER ROW
Hrow = MsgBox("Do you have a header row in this file?" _
& vbCrLf & vbCrLf & " If so, HIT YES TO DELETE. CareTracker" _
& " will not Accept a Header Row." & vbCrLf & vbCrLf & " If not," _
& " HIT NO TO CONTINUE.", vbYesNo, "Header Row?")
  If Hrow = vbYes Then
JMX1:      Range("A1").EntireRow.Delete
  End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'THIS IS WHERE YOU DEFINE IF YOU HAVE A DEMOGRAPHIC OR AN APPOINTMENT FILE
NumCols = InputBox("Please enter the number 19 if this an appointment file or the number" _
& "67 if this is a demographic file", "Appt or Demo", "ONLY 19 OR 67")
If NumCols = vbCancel Then
  End
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'GIVE OPTION TO CHECK FOR DUPLICATES
Dim ODups As String
  If NumCols = "67" Then
    ActiveSheet.Name = "CTFILE"
      ODups = MsgBox("Do you want to check your demographic file for duplicates?" _
      & vbCrLf & "This program checks based on the following" _
      & vbCrLf & vbCdrLf & "(Column A) Chart Number" _
      & vbCrLf & "(Column B)/> SSN", vbYesNo, "Check for Dups?")
            If ODups = vbYes Then
                Call D_CheckDups
                    If C2L = vbNo Then
                        End
                    End If
            End If
  End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'USE THIS PIECE TO CHECK FOR BAD SYMBOLS AND DELETE
If NumCols = "19" Then
    ActiveSheet.Name = "CTFILE"
  eA_FixAppts = MsgBox("Do you want to check your Appointment File for bad characters? " _
  & vbCrLf & "This will also format certain columns for you." _
  & vbCrLf & vbCrLf & "Fix Date Format" _
  & vbCrLf & "Fix Time Format" _
  & vbCrLf & "Check Length of Fields" _
  & vbCrLf & "Remove All Bad Characters", vbYesNo + vbInformation, "Appt File")
      If eA_FixAppts = vbYes Then
Call A_FixAppts
Call U_DeleteQuotes
      End If
End If

If NumCols = "67" Then
  eD_FixDemos = MsgBox("Do you want to check your Demographic File for bad characters " _
  & vbCrLf & "and check / repair field formatting on the following?" _
  & vbCrLf & vbCrLf & "Home Phone & Work Phone" _
  & vbCrLf & "Home Zip and Work Zip - Adding leading zero's" _
  & vbCrLf & "SSN - Adding Leading Zero's" & vbCrLf & "Date of Birth" _
  & vbCrLf & "Removes Bad Charaters from all 3 Insurance Addresses" _
  & vbCrLf & "Checks Length of Insurance Addresses & ID's" _
  & vbCrLf & "Check Length of Notes Field" _
  & vbCrLf & "Appends CoPay with CP=" _
  & vbCrLf & "Cleans Notes Field of Carriage Returns" _
  , vbYesNo, "Demographic File")
  
      If eD_FixDemos = vbYes Then
        Call D_FixDemos
        Call U_DeleteQuotes
      End If
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'THIS IS WHERE WE AUTOMATICALLY SELECT THE FIRST CELL TO AVOID ANY MISSED COLUMNS
Range("A1").Select
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'THIS TELLS THE MACRO TO GET ALL INFO EVEN IN UNOPENED COLUMNS
  For ColumnCount = 1 To NumCols
    Cells.Select
    Cells.EntireColumn.AutoFit
  Next
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'THIS IS WHERE YOU NAME YOUR FILE
  filenam = InputBox("Please enter a name for your new file with out typing .csv", "File Name", _
  "YOU DON'T NEED TO TYPE .CSV!")
      If filenam = "" Or filenam = "YOU DON'T NEED TO TYPE .CSV!" Then
        MsgBox "Invalid File Name"
      End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'THIS IS WHERE WE PICK THE LOCATION OF THE OUTPUT FILE
  With Application.FileDialog(msoFileDialogFolderPicker)
      .AllowMultiSelect = True
      .InitialFileName = ""
      .Show
      STRFOLDER = .SelectedItems(1)
  End With
  DestFile = STRFOLDER & "\" & filenam & ".csv"
  FileNum = FreeFile()
  On Error Resume Next
  Open DestFile For Output As #FileNum
  If Err <> 0 Then
    MsgBox "Cannot open filename " & DestFile
    End
  End If
  On Error GoTo 0
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'HERE WE START CREATING THE FINAL CSV DOCUMENT
  Selection.Columns.AutoFit
  For RowCount = 1 To ActiveSheet.UsedRange.Rows.Count
    For ColumnCount = 1 To NumCols
      Print #FileNum, """" & Trim(Selection.Cells(RowCount, _
            ColumnCount).Text) & """";
      If ColumnCount = NumCols Then
            Print #FileNum,
      Else
            Print #FileNum, ",";
      End If
    Next ColumnCount
  Next RowCount
  Close #FileNum
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'MAKING SURE YOU CAN TELL WHEN THE SUB HAS FINISHED AND OFFERING HELPFUL ADVICE
    MsgBox ("Please view your file in notepad now to make sure that it's correct."), vbExclamation, "*~*~*~*DONE!*~*~*~*"
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Private Sub A_FixAppts()
    
    Dim AppLastRow As Long
    Dim AppRowCount As Long
    Dim AppProName As Long                              '
    Dim AppProID As Long
    Dim L2L1 As Long
    Dim C2L1 As String
    Dim AMPM As String
    Dim TVAL As String
    Dim intTimeLastRow As Long
    Dim intTimeRowCount As Long
    Dim strappttime As String
    Dim strhour As String
    Dim strmin As String
    Dim AppTypeID As Long
    Dim AppTypeName As Long
    Dim AppLocID As Long
    Dim AppLocName As Long
    Dim AppComplain As Long
    Dim AppGroupID As Long
    Dim AppGroupName As Long
        
    TVAL = ActiveCell.Value
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::   IF YOUR FILE HAS BEEN IMPORTED TO EXCEL AS TEXT THIS WILL NOT WORK AND YOU   :::
':::        WILL HAVE TO USE A SEPARATE MACRO DEPENDING ON THE SITUATION            :::
'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
 
'START BY ATTEMPTING TO FIX THE DOB WITH A FORMAT FORMULA.
Range("A:A").Select
Selection.NumberFormat = "mm/dd/yyyy"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'FORMAT TIME SO THAT THE LETTERS ARE FORMATABLE. IE 6:45p TO 6:45 PM
Range("B:B").Select

AMPM = Right(TVAL, 1)

        Selection.Replace What:="p", Replacement:="PM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Selection.Replace What:="a", Replacement:="AM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Selection.Replace What:="AMM", Replacement:="AM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Selection.Replace What:="PMM", Replacement:="PM", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'ALSO TRY TO FIX TIME
    intTimeLastRow = ActiveSheet.UsedRange.Rows.Count
    
    For intTimeRowCount = 2 To intTimeLastRow
    
        Range("B" & intTimeRowCount).Select
        strappttime = ActiveCell.Value
        
        ' Determine length
        ' If length of data is 5, then it is HH24 time (military)
        ' If length of data is 8, it is HH:MM AM time (non-military), or HH:MM:SS
        ' If length of data is 4 (HHMM), assume military, no colon present
        ' All data parses should be numeric for HH and MM
        Select Case Len(strappttime)
            Case 4, 5 ' military
                strhour = Left(strappttime, 2)
                strmin = Right(strappttime, 2)
            Case 8 ' AM/PM or HH:MM:SS
                strhour = Left(strappttime, 2)
                strmin = Mid(strappttime, 4, 2)
            Case 3 ' single digit hour, no colon
                strhour = "0" & Left(strappttime, 1)
                strmin = Right(strappttime, 2)
            Case Else ' Nothing
        
        End Select
        
        If (Val(strhour) < 12) Then
            strappttime = strhour & ":" & strmin & "AM"
        ElseIf (Val(strhour) = 12) Then
            strappttime = strhour & ":" & strmin & "PM"
        Else
            sHour = (Val(strhour) - 12)
            If Len(sHour) = 1 Then
                sHour = "0" & sHour
                strappttime = sHour & ":" & strmin & "PM"
            Else
                strappttime = (Val(strhour) - 12) & ":" & strmin & "PM"
            End If
        End If
        
        ActiveCell.FormulaR1C1 = strappttime
        
    Next intTimeRowCount
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    AppRowCount = ActiveSheet.UsedRange.Rows.Count
    
    'CHECK LENGTH OF APPT TYPE ID
    For AppTypeID = 1 To AppRowCount
        Range("D" & AppTypeID).Select
            If Len(ActiveCell) > 10 Then
                L2L1 = L2L1 + 1
                ActiveCell.Interior.ColorIndex = 4
                With ActiveCell.Characters(Start:=11, Length:=2000).Font
                    .Name = "Arial"
                    .FontStyle = "Bold"
                    .Size = 12
                    .ColorIndex = 3
                End With
            End If
    Next AppTypeID
    
    'CHECK LENGTH OF APPT TYPE NAME
    For AppTypeName = 1 To AppRowCount
        Range("E" & AppTypeName).selecet
            If Len(ActiveCell) > 20 Then
                L2L1 = L2L1 + 1
                ActiveCell.Interior.ColorIndex = 4
                With ActiveCell.Characters(Start:=21, Length:=2000).Font
                    .Name = "Arial"
                    .FontStyle = "Bold"
                    .Size = 12
                    .ColorIndex = 3
                End With
            End If
    'CHECK LENGTH OF PROVIDER ID
    For AppProID = 1 To AppRowCount
        Range("F" & AppProID).Select
            If Len(ActiveCell) > 10 Then
                L2L1 = L2L1 + 1
                ActiveCell.Interior.ColorIndex = 4
                With ActiveCell.Characters(Start:=11, Length:=2000).Font
                    .Name = "Arial"
                    .FontStyle = "Bold"
                    .Size = 12
                    .ColorIndex = 3
                End With
            End If
    Next AppProID
    
    'CHECK LENGTH OF PROVIDER NAME
    For AppProName = 1 To AppRowCount
        Range("G" & AppProName).Select
        If Len(ActiveCell) > 20 Then
            L2L1 = L2L1 + 1
            ActiveCell.Interior.ColorIndex = 4
            With ActiveCell.Characters(Start:=21, Length:=2000).Font
                .Name = "Arial"
                .FontStyle = "Bold"
                .Size = 12
                .ColorIndex = 3
            End With
        End If
    Next AppProName
    
    'CHECK LENGTH OF LOCATION ID
    For AppLocID = 1 To AppRowCount
        Range("H" & AppLocID).Select
            If Len(ActiveCell) > 10 Then
            L2L1 = L2L1 + 1
            ActiveCell.Interior.ColorIndex = 4
            With ActiveCell.Characters(Start:=11, Length:=2000).Font
                .Name = "Arial"
                .FontStyle = "Bold"
                .Size = 12
                .ColorIndex = 3
            End With
        End If
    Next AppLocID
    
    'CHECK LENGTH OF LOCATION NAME
    For AppLocName = 1 To AppRowCount
        Range("I" & AppLocName).Select
            If Len(ActiveCell) > 50 Then
            L2L1 = L2L1 + 1
            ActiveCell.Interior.ColorIndex = 4
            With ActiveCell.Characters(Start:=51, Length:=2000).Font
                .Name = "Arial"
                .FontStyle = "Bold"
                .Size = 12
                .ColorIndex = 3
            End With
        End If
    Next AppLocName
    'CHECK LENGTH OF GROUP ID
    For AppGroupID = 1 To AppRowCount
        Range("J" & AppGroupID).Select
            If Len(ActiveCell) > 10 Then
            L2L1 = L2L1 + 1
            ActiveCell.Interior.ColorIndex = 4
            With ActiveCell.Characters(Start:=11, Length:=2000).Font
                .Name = "Arial"
                .FontStyle = "Bold"
                .Size = 12
                .ColorIndex = 3
            End With
        End If
    Next AppGroupID
    'CHECK LENGTH OF GROUP NAME
    For AppGroupName = 1 To AppRowCount
        Range("K" & AppGroupName).Select
            If Len(ActiveCell) > 50 Then
            L2L1 = L2L1 + 1
            ActiveCell.Interior.ColorIndex = 4
            With ActiveCell.Characters(Start:=51, Length:=2000).Font
                .Name = "Arial"
                .FontStyle = "Bold"
                .Size = 12
                .ColorIndex = 3
            End With
        End If
    Next AppGroupName
    'CHECK LENGTH OF NOTES FIELD(APPT)
    For AppLastRow = 1 To AppRowCount
    Range("M" & AppLastRow).Select
        If Len(ActiveCell) > 2000 Then
            L2L1 = L2L1 + 1
            ActiveCell.Interior.ColorIndex = 4
            With ActiveCell.Characters(Start:=2001, Length:=2000).Font
                .Name = "Arial"
                .FontStyle = "Bold"
                .Size = 12
                .ColorIndex = 3
            End With
        End If
    Next AppLastRow
    
    'CHECK LENGTH OF COMPLAINT FIELD
    For AppComplain = 1 To AppRowCount
        Range("N" & AppComplain).Select
        If Len(ActiveCell) > 100 Then
            L2L1 = L2L1 + 1
            ActiveCell.Interior.ColorIndex = 4
            With ActiveCell.Characters(Start:=2001, Length:=2000).Font
                .Name = "Arial"
                .FontStyle = "Bold"
                .Size = 12
                .ColorIndex = 3
            End With
        End If
    Next AppComplain
    If L2L1 > 0 Then
        C2L1 = MsgBox("You have rows that are too long to be imported to CareTracker." _
                & vbCrLf & vbCrLf & "Press Yes to shorten these rows down to the correct amount of characters." _
                & vbCrLf & vbCrLf & "Press No to have them highlighted in Green w/ Bad Char's in Red Font and fix yourself.", _
                vbYesNo + vbCritical, "Notes Section Too Long!")
            If C2L1 = vbYes Then
                Call A_ApptLenFixer
            Else
                End
            End If
    End If
    
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Private Sub D_FixDemos()
    Dim strLen As String
    Dim intLastRow As Long
    Dim intRowCount As Long
    Dim L2L As Long                                          'MORE
    Dim C2L As String
    Dim intLastRow1 As Long
    Dim intRowCount1 As Long
    Dim Coval As Long
    Dim Co1 As Long
    Dim Co2 As Long
    Dim Co3 As Long
    Dim CPVal As String
    Dim CP1 As String
    Dim CP2 As String
    Dim CP3 As String
    Dim intlastnote As Long
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'REPLACE ANY CELLS THAT CONTAIN A SINGLE 0 AS NULL VALUE
Cells.Select
Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, SearchOrder _
:=xlByRows, MatchCase:=True, SearchFormat:=False, ReplaceFormat:=False
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'FIX HOME PHONE
Range("O:O").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

Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'FIX WORK PHONE
Range("Y:Y").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

Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'FIX THE SSN
Range("B:B").Select
Selection.NumberFormat = "000000000"
Selection.Replace What:="-", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'FIX HOME ZIP CODES
Range("M:M").Select
Selection.NumberFormat = "00000"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'FIX WORK ZIP CODES
Range("W:W").Select
Selection.NumberFormat = "00000"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'FIX DOB
Range("G:G").Select
Selection.NumberFormat = "mm/dd/yyyy"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'FIX INSURANCE 1 ADDRESS -- REMOVE PERIODS AND SPACES IN PO BOX
Range("AH:AH").Select
Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="P O", Replacement:="PO", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'FIX INSURANCE 2 ADDRESS
Range("AP:AP").Select
Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="P O", Replacement:="PO", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'FIX INSURANCE 3 ADDRESS
Range("AX:AX").Select
Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="P O", Replacement:="PO", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'CHECK LENGTH OF NOTES FIELD(DEMO)
    
    intRowCount = ActiveSheet.UsedRange.Rows.Count
    
    For intLastRow = 1 To intRowCount
    
    Range("AD" & intLastRow).Select
        If Len(ActiveCell) > 250 Then
            L2L = L2L + 1
            ActiveCell.Interior.ColorIndex = 4
            With ActiveCell.Characters(Start:=251, Length:=2000).Font
                .Name = "Arial"
                .FontStyle = "Bold"
                .Size = 12
                .ColorIndex = 3
            End With
        End If
    Next intLastRow
    
    If L2L > 0 Then
        C2L = MsgBox("You have rows that are too long to be imported to CareTracker." _
                & vbCrLf & vbCrLf & "Press Yes to shorten these notes down to correct amount of characters." _
                & vbCrLf & vbCrLf & "Press No to have them highlighted in Green and fix yourself.", _
                vbYesNo + vbCritical, "Notes Section Too Long!")
            If C2L = vbYes Then
                Call A_ApptLenFixer
            Else
                End
            End If
    End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    'CHECK LENGTH OF INS ADDRESS FIELDS
    
    intRowCount1 = ActiveSheet.UsedRange.Rows.Count
'***************************************
    'CHECK ADDRESS 1
    For intLastRow1 = 1 To intRowCount1
    Range("AG" & intLastRow1).Select
        If Len(ActiveCell) > 50 Then
            L2L = L2L + 1
            ActiveCell.Interior.ColorIndex = 4
            With ActiveCell.Characters(Start:=51, Length:=2000).Font
                .Name = "Arial"
                .FontStyle = "Bold"
                .Size = 12
                .ColorIndex = 3
            End With
        End If
    Next intLastRow1
'****************************************
    'CHECK ADDRESS 2
    For intLastRow1 = 1 To intRowCount1
    Range("AO" & intLastRow1).Select
        If Len(ActiveCell) > 50 Then
            L2L = L2L + 1
            ActiveCell.Interior.ColorIndex = 4
            With ActiveCell.Characters(Start:=51, Length:=2000).Font
                .Name = "Arial"
                .FontStyle = "Bold"
                .Size = 12
                .ColorIndex = 3
            End With
        End If
    Next intLastRow1
'*******************************************
    'CHECK ADDRESS 3
    For intLastRow1 = 1 To intRowCount1
    Range("AW" & intLastRow1).Select
        If Len(ActiveCell) > 50 Then
            L2L = L2L + 1
            ActiveCell.Interior.ColorIndex = 4
            With ActiveCell.Characters(Start:=51, Length:=2000).Font
                .Name = "Arial"
                .FontStyle = "Bold"
                .Size = 12
                .ColorIndex = 3
            End With
        End If
    Next intLastRow1
'********************************************
    'FIX IF NECESSARY
    If L2L > 0 Then
        C2L = MsgBox("You have insurance addresses that are too long to be imported to CareTracker." _
                & vbCrLf & vbCrLf & "Press Yes to shorten these rows down to the correct amount of characters." _
                & vbCrLf & vbCrLf & "Press No to have them highlighted in Green & Red and fix yourself.", _
                vbYesNo + vbCritical, "Notes Section Too Long!")
            If C2L = vbYes Then
                Call D_InsAddFixer
            Else
                End
            End If
    End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    'CHECK FOR INSURANCE COPAY AND IF YES OFFER TO APPEND WITH CP=
    
    Coval = ActiveSheet.UsedRange.Rows.Count
    
    CPVal = ActiveCell.Value
'********************************************
    'INS 1 COPAY
    For Co1 = 1 To Coval
        Range("AJ" & Co1).Select
        CP1 = Left(CPVal, 2)
        If Not (Val(CP1) = CP) Then
            ActiveCell.Value = "CP=" & ActiveCell.Value
        End If
    Next Co1
'********************************************
    'INS 2 COPAY
    For Co2 = 1 To Coval
        Range("AR" & Co2).Select
        CP2 = Left(CPVal, 2)
        If Not (Val(CP2) = CP) Then
            ActiveCell.Value = "CP=" & ActiveCell.Value
        End If
    Next Co2
'********************************************
    'INS 3 COPAY
    For Co3 = 1 To Coval
        Range("AZ" & Co3).Select
        CP3 = Left(CPVal, 2)
        If Not (Val(CP3) = CP) Then
            ActiveCell.Value = "CP=" & ActiveCell.Value
        End If
    Next Co3
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'THIS IS WHERE WE CLEAN THE NOTES SECTION IN CASE OF CARRIAGE RETURNS OR OTHER
'BAD CHARACTERS
    intlastnote = ActiveSheet.UsedRange.Rows.Count

    Columns("AE:AE").Select
    Selection.Insert Shift:=xlToRight
    Range("AE1").Select
    Columns("AE:AE").Select
    Selection.Insert Shift:=xlToRight
    ActiveCell.FormulaR1C1 = "=CLEAN(RC[-1])"
    Range("AE1").Select
    Selection.Cut
    Application.CutCopyMode = False
    Selection.Copy
    Range("AE2").Select
    ActiveSheet.Paste
    Columns("AE:AE").Select
    Application.CutCopyMode = False
    Selection.Copy
    Columns("AD:AD").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("AE:AE").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Range("AE1").EntireColumn.Delete

End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Private Sub D_InsAddFixer()
    Dim inLastRow1 As Long
    Dim inRowCount1 As Long
    
        inRowCount1 = ActiveSheet.UsedRange.Rows.Count
'********************************************
        'FIX INS ADD 1
        For inLastRow1 = 1 To inRowCount1
            Range("AG" & inLastRow1).Select
                If Len(ActiveCell) > 50 Then
                    ActiveCell.Characters(Start:=51, Length:=2000).Delete
                End If
        Next inLastRow1
'********************************************
        'FIX INS ADD 2
        For inLastRow1 = 1 To inRowCount1
            Range("AO" & inLastRow1).Select
                If Len(ActiveCell) > 50 Then
                    ActiveCell.Characters(Start:=51, Length:=2000).Delete
                End If
        Next inLastRow1
'********************************************
        'FIX INS ADD 3
        For inLastRow1 = 1 To inRowCount1
            Range("AW" & inLastRow1).Select
                If Len(ActiveCell) > 50 Then
                    ActiveCell.Characters(Start:=51, Length:=2000).Delete
                End If
        Next inLastRow1
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Private Sub A_ApptLenFixer()
'DELETE FIELDS IN APPTS THAT ARE TOO LONG
    Dim intNoteLastRow As Long
    Dim intAppLenCount As Long
    Dim intProLastRow As Long
    Dim intProId As Long
    Dim intTypeID As Long
    Dim intTypeName As Long
    Dim intLocId As Long
    Dim intLocName As Long
        
        intAppLenCount = ActiveSheet.UsedRange.Rows.Count
        'FIX LENGTH OF APPT TYPE ID
        For intTypeID = 1 To intAppLenCount
            Range("D" & intTypeID).Select
                If Len(ActiveCell) > 10 Then
                    ActiveCell.Characters(Start:=11, Length:=200).Delete
                End If
        Next intTypeID
        'FIX LENGTH OF APPT TYPE NAME
        For intTypeName = 1 To intAppLenCount
            Range("E" And intTypeName).Select
                If Len(ActiveCell) > 50 Then
                    ActiveCell.Characters(Start:=51, Length:=200).Delete
                End If
        Next intTypeName
        'FIX LENGTH OF PROVIDER ID
        For intProId = 1 To intAppLenCount
            Range("F" & intAppLenCount).Select
                If Len(ActiveCell) > 10 Then
                    ActiveCell.Characters(Start:=11, Length:=200).Delete
                End If
        Next intProId
        'FIX LENGTH OF PROVIDER NAME
        For intProLastRow = 1 To intAppLenCount
            Range("G" & intProLastRow).Select
                If Len(ActiveCell) > 20 Then
                    ActiveCell.Characters(Start:=21, Length:=200).Delete
                End If
        Next intProLastRow
        'FIX LENGTH OF LOCATION ID
        For intLocId = 1 To intAppLenCount
            Range("H" & intLocId).Select
                If Len(ActiveCell) > 10 Then
                    ActiveCell.Characters(Start:=11, Length:=200).Delete
                End If
        Next intLocId
        'FIX LENGTH OF LOCATION NAME
        For intLocName = 1 To intAppLenCount
            Range("I" & intLocName).Select
                If Len(ActiveCell) > 20 Then
                    ActiveCell.Characters(Start:=21, Length:=200).Delete
                End If
        Next intLocName
        'FIX LENGTH OF NOTES
        For intNoteLastRow = 1 To intAppLenCount
            Range("AD" & intNoteLastRow).Select
                If Len(ActiveCell) > 250 Then
                    ActiveCell.Characters(Start:=251, Length:=2000).Delete
                End If
        Next intNoteLastRow
        
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Private Sub U_DeleteQuotes()
'CHECK WHOLE FILE FOR QUOTES
Cells.Select
Selection.Replace What:="""", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
       
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Private Sub D_CheckDups()
'THIS IS THE PART THAT IDENTIFIES DUPLICATE CELLS. WE DO THIS BASED ON MRN & SSN
    Dim UGOTDUPS As String                                     '

    Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom


    firstitem = ActiveCell.Value & ActiveCell.Offset(0, 1).Value
    seconditem = ActiveCell.Offset(1, 0).Value & ActiveCell.Offset(1, 1).Value
    Offsetcount = 1

      Do While ActiveCell <> ""
      
      If firstitem = seconditem Then
        ActiveCell.Offset(Offsetcount, 0).Interior.Color = RGB(255, 0, 0)
        Offsetcount = Offsetcount + 1
        seconditem = ActiveCell.Offset(Offsetcount, 0).Value
        dupcount = dupcount + 1
      Else
        ActiveCell.Offset(Offsetcount, 0).Select
        firstitem = ActiveCell.Value
        seconditem = ActiveCell.Offset(1, 0).Value
        Offsetcount = 1
      End If
Loop
        If dupcount > 0 Then
            UGOTDUPS = MsgBox("You have duplicate chart numbers in your file! Would you like to delete these based on Fields 1 & 2?" _
                    & vbCrLf & vbCrLf & "HIT YES TO DELETE DUPLICATES." _
                    & vbCrLf & vbCrLf & "HIT NO TO REMOVE DUPLICATES AND CREATE" _
                    & "A NEW REPORT WITH A LIST OF THESE DUPLICATES", vbYesNo + vbCritical, "Look out for dups!")
                If UGOTDUPS = vbYes Then
                    Call U_DelDups
                End If
                If UGOTDUPS = vbNo Then
                    Call D_DupReport
                End If
                 Else
                MsgBox "No Duplicates Found", vbOK, "No Dups Found"
       End If
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Private Sub U_DelDups()
'THIS IS WHERE WE DELETE DUPLICATES IF TOLD TO DO SO
    Dim dupcount As Long                                     '
    
    dupcount = 0
    Range("A1").Select
    Do While ActiveCell <> ""
        If ActiveCell.Interior.ColorIndex = 3 Then
            ActiveCell.EntireRow.Delete
            dupcount = dupcount + 1
            Else
            ActiveCell.Offset(1, 0).Select
        End If
    Loop
    MsgBox dupcount & " duplicates deleted"
End Sub
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Private Sub D_DupReport()
'THIS IS WHERE WE CREATE A DUPLICATE REPORT INSTEAD OF DELETING
    Dim dupsmoved As Long                                       '
    Static intFNum As Long
    Static intDNum As Long
    intFNum = intFNum + 1
    ActiveSheet.Name = "CTFILE" & intFNum
    intDNum = intDNum + 1
    DS4 = Worksheets.Add.Name = "DUPLICATE REPORT" & intDNum
    dupsmoved = 0
    Worksheets("CTFILE" & intFNum).Select
    Range("A1").Select
    Do While ActiveCell <> ""
        If ActiveCell.Interior.ColorIndex = 3 Then
            ActiveCell.EntireRow.Cut
            Sheets("DUPLICATE REPORT" & intDNum).Select
                If Range("A1") <> 0 Then
                    NextRow = Range("A65536").End(xlUp).Row + 1
                    Range("A" & NextRow).Select
                End If
            ActiveSheet.Paste
            dupsmoved = dupsmoved + 1
            Sheets("CTFILE" & intFNum).Select
            ActiveCell.Offset(1, 0).Select
                Else
            ActiveCell.Offset(1, 0).Select
        End If
    Loop
    Cells.Select
    
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom

    MsgBox dupsmoved & " duplicates removed and moved to DUPLICATE REPORT " & intFNum
End Sub




Is This A Good Question/Topic? 0
  • +

Replies To: Using Access to Call an XLS, run a macro and export

#2 thava   User is offline

  • D.I.C Lover
  • member icon

Reputation: 180
  • View blog
  • Posts: 1,607
  • Joined: 17-April 07

Re: Using Access to Call an XLS, run a macro and export

Posted 19 April 2010 - 05:18 PM

surely this link will help you

How to run subroutines and macros from Visual Basic in Excel 2000 or Excel 2002
Was This Post Helpful? 1
  • +
  • -

#3 guyfromri   User is offline

  • D.I.C Addict

Reputation: 46
  • View blog
  • Posts: 836
  • Joined: 16-September 09

Re: Using Access to Call an XLS, run a macro and export

Posted 20 April 2010 - 04:37 AM

View Postthava, on 19 April 2010 - 04:18 PM, said:



That's exactly what I was looking for. Thank you very much!
Was This Post Helpful? 0
  • +
  • -

Page 1 of 1