Any one help to reduce the macro

A

anilg0001

Rules Violation
Joined
Jun 7, 2010
Messages
193
I am new in VBA
I know the below coading are not at all perfect but it run perfectly what i want.

any one help to alternate this coding coding


Sub details()
Dim l As Long
Dim AdrFIND As Range
Dim AdrNEXT As Range
Dim a

Range("B1") = "Year Established:"
Range("B2") = "Capacity:"
Range("B3") = "Cost/Month:"
Range("B4") = "Funding:"
Range("B5") = "Subsidy Available:"
Range("B6") = "Owner(s):"
Range("B7") = "Able to retain own MD:"
Range("B8") = "Trained for visually/hearing impaired:"
Range("B9") = "Visiting MD:"
Range("B10") = "Number of Sittings per meal :"
Range("B11") = "Waiting Period:"
Range("B12") = "Average Age:"
Range("B13") = "Pets Allowed:"
Range("B14") = "Wheelchair Access:"
Range("B15") = "Languages Spoken:"
Range("B16") = "Religion:"
Range("B17") = "Accept Public Guardian Case (Power of Attorney) :"
Range("B18") = "Meals included in price/month:"
Range("B19") = "Associations:"
Range("B21") = "Amenities:"
Range("B23") = "Staff Services:"
Range("B25") = "Accommodation:"
Range("B27") = "Accommodation Details:"
Range("B29") = "Special Diets:"
Range("B31") = "Close Facilities:"

l = Sheets("Macro").Range("A" & Rows.Count).End(xlUp).Row
For l = l To 1 Step -1
If InStr(1, Sheets("Macro").Cells(l, 1), "Year Established:", vbTextCompare) Then
Range("B1") = Cells(l, 1).Value
'Else: Range("B1") = "Year Established:"
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Capacity:", vbTextCompare) Then
Range("B2") = Cells(l, 1).Value
'Else: 'Range("B2") = "Capacity:"
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Cost/Month:", vbTextCompare) Then
Range("B3") = Cells(l, 1).Value
'Else: Range("B3") = "Cost/Month:"
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Funding:", vbTextCompare) Then
Range("B4") = Cells(l, 1).Value
'Else: Range("B3") = "Cost/Month:"
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Subsidy Available:", vbTextCompare) Then
Range("B5") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Owner(s):", vbTextCompare) Then
Range("B6") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Able to retain own MD:", vbTextCompare) Then
Range("B7") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Trained for visually/hearing impaired:", vbTextCompare) Then
Range("B8") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Visiting MD:", vbTextCompare) Then
Range("B9") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Number of Sittings per meal :", vbTextCompare) Then
Range("B10") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Waiting Period:", vbTextCompare) Then
Range("B11") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Average Age:", vbTextCompare) Then
Range("B12") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Pets Allowed:", vbTextCompare) Then
Range("B13") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Wheelchair Access:", vbTextCompare) Then
Range("B14") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Languages Spoken:", vbTextCompare) Then
Range("B15") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Religion", vbTextCompare) Then
Range("B16") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Accept Public Guardian Case (Power of Attorney)", vbTextCompare) Then
Range("B17") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Meals included in price/month:", vbTextCompare) Then
Range("B18") = Cells(l, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Associations", vbTextCompare) Then
Range("B20") = Cells(l + 2, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Amenities", vbTextCompare) Then
Range("B22") = Cells(l + 2, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Staff Services:", vbTextCompare) Then
Range("B24") = Cells(l + 2, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Accommodation:", vbTextCompare) Then
Range("B26") = Cells(l + 2, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Accommodation Details:", vbTextCompare) Then
Range("B28") = Cells(l + 2, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Special Diets:", vbTextCompare) Then
Range("B30") = Cells(l + 2, 1).Value
End If
If InStr(1, Sheets("Macro").Cells(l, 1), "Close Facilities:", vbTextCompare) Then
Range("B32") = Cells(l + 2, 1).Value
End If

If Range("B20") = "Associations" Then
Range("B20") = ""
End If
If Range("B20") = "Amenities" Then
Range("B20") = ""
End If
If Range("B20") = "Staff Services:" Then
Range("B20") = ""
End If
If Range("B20") = "Accommodation" Then
Range("B20") = ""
End If
If Range("B20") = "Accommodation Details:" Then
Range("B20") = ""
End If
If Range("B20") = "Special Diets:" Then
Range("B20") = ""
End If
If Range("B20") = "Close Facilities:" Then
Range("B20") = ""
End If

If Range("B22") = "Associations" Then
Range("B22") = ""
End If
If Range("B22") = "Amenities" Then
Range("B22") = ""
End If
If Range("B22") = "Staff Services:" Then
Range("B22") = ""
End If
If Range("B22") = "Accommodation" Then
Range("B22") = ""
End If
If Range("B22") = "Accommodation Details:" Then
Range("B22") = ""
End If
If Range("B22") = "Special Diets:" Then
Range("B22") = ""
End If
If Range("B22") = "Close Facilities:" Then
Range("B22") = ""
End If

If Range("B24") = "Associations" Then
Range("B24") = ""
End If
If Range("B24") = "Amenities" Then
Range("B24") = ""
End If
If Range("B24") = "Staff Services:" Then
Range("B24") = ""
End If
If Range("B24") = "Accommodation" Then
Range("B24") = ""
End If
If Range("B24") = "Accommodation Details:" Then
Range("B24") = ""
End If
If Range("B24") = "Special Diets:" Then
Range("B24") = ""
End If
If Range("B24") = "Close Facilities:" Then
Range("B24") = ""
End If

If Range("B26") = "Associations" Then
Range("B26") = ""
End If
If Range("B26") = "Amenities" Then
Range("B26") = ""
End If
If Range("B26") = "Staff Services:" Then
Range("B26") = ""
End If
If Range("B26") = "Accommodation" Then
Range("B26") = ""
End If
If Range("B26") = "Accommodation Details:" Then
Range("B26") = ""
End If
If Range("B26") = "Special Diets:" Then
Range("B26") = ""
End If
If Range("B26") = "Close Facilities:" Then
Range("B26") = ""
End If

If Range("B28") = "Associations" Then
Range("B28") = ""
End If
If Range("B28") = "Amenities" Then
Range("B28") = ""
End If
If Range("B28") = "Staff Services:" Then
Range("B28") = ""
End If
If Range("B28") = "Accommodation" Then
Range("B28") = ""
End If
If Range("B28") = "Accommodation Details:" Then
Range("B28") = ""
End If
If Range("B28") = "Special Diets:" Then
Range("B28") = ""
End If
If Range("B28") = "Close Facilities:" Then
Range("B28") = ""
End If

If Range("B30") = "Associations" Then
Range("B30") = ""
End If
If Range("B30") = "Amenities" Then
Range("B30") = ""
End If
If Range("B30") = "Staff Services:" Then
Range("B30") = ""
End If
If Range("B30") = "Accommodation" Then
Range("B30") = ""
End If
If Range("B30") = "Accommodation Details:" Then
Range("B30") = ""
End If
If Range("B30") = "Special Diets:" Then
Range("B30") = ""
End If
If Range("B30") = "Close Facilities:" Then
Range("B30") = ""
End If

If Range("B32") = "Associations" Then
Range("B32") = ""
End If
If Range("B32") = "Amenities" Then
Range("B32") = ""
End If
If Range("B32") = "Staff Services:" Then
Range("B32") = ""
End If
If Range("B32") = "Accommodation" Then
Range("B32") = ""
End If
If Range("B32") = "Accommodation Details:" Then
Range("B32") = ""
End If
If Range("B32") = "Special Diets:" Then
Range("B32") = ""
End If
If Range("B32") = "Close Facilities:" Then
Range("B32") = ""
End If

Next l

Range("B1:B32").Select
Range("B1:B32").Copy
End Sub
 

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
Sort by date Sort by votes
Code: 
Sub details()
Dim megalist, lstrow As Long, l As Long, cell As Range
    
    megalist = _
Array("Year Established:", "Capacity:", "Cost/Month:", "Funding:", "Subsidy Available:", "Owner(s):", "Able to retain own MD:", _
"Trained for visually/hearing impaired:", "Visiting MD:", "Number of Sittings per meal :", "Waiting Period:", "Average Age:", _
"Pets Allowed:", "Wheelchair Access:", "Languages Spoken:", "Religion:", "Accept Public Guardian Case (Power of Attorney) :", _
"Meals included in price/month:", "Associations:", "", "Amenities:", "", "Staff Services:", "", "Accommodation:", "", "Accommodation Details:", _
"", "Special Diets:", "", "Close Facilities:")
    For lstrow = 1 To 31
        If lstrow < 20 Or lstrow Mod 2 = 1 Then Cells(lstrow, 2) = megalist(lstrow - 1)
            For l = Sheets("Macro").Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
                If InStr(1, Sheets("Macro").Cells(l, 1), megalist(lstrow - 1), vbTextCompare) Then Cells(lstrow, 2) = Cells(l, 1).Value
            Next
    Next
For Each cell In Range("B20:B32")
If cell.Row Mod 2 = 0 Then
If cell = cell.Offset(-1, 0) Then cell.ClearContents
End If
Next
Range("B1:B32").Copy
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
Delete Rows That Do Not Meet Criteria
2
Replies
11
Views
1K
bebo021999
B
redspanna
  • Question
Merge 2 VB codes and add Application.screenupdating
Replies
2
Views
375
Bosquedeguate
Bosquedeguate
S
  • Solved
Miscrosoft has Blocking The Macro Sometimes and disabling the macros
Replies
5
Views
410
NdNoviceHlp
NdNoviceHlp
J
  • Question
Should I consider any obvious methods or restructuring to speed up macro?
Replies
1
Views
292
Herakles
H
esset
  • Solved
Splitting hours worked into multiple shift patterns
Replies
3
Views
551
esset
esset

Forum statistics

Threads
1,214,979
Messages
6,122,551
Members
449,088
Latest member
davidcom

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top