API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Apr 17th, 2019
125
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VisualBasic 8.17 KB | None | 0 0
raw download clone embed print report
  1. Option Explicit
  2.  
  3. Sub letsmakecallsheets_and_detectphonecolumn()
  4.  
  5.  
  6. 'Set up variables, disable screenupdating to speed up
  7.  
  8. Dim thisWb As Workbook
  9. Dim cWb As Workbook
  10. Dim cSheet As Worksheet
  11. Dim cTeam As Worksheet
  12. Dim lastRow As Long
  13. Dim logCol As Long
  14. Dim cSheetCol As Long
  15. Dim colLetter As String
  16.  
  17.  
  18.  
  19.  
  20. Application.ScreenUpdating = False
  21. Application.DisplayAlerts = False
  22.  
  23.  
  24.  
  25. Set thisWb = ActiveWorkbook
  26. Set cTeam = thisWb.ActiveSheet
  27. Set cWb = Workbooks.Add
  28. Set cSheet = cWb.Worksheets(1)
  29. lastRow = cTeam.Cells(Rows.Count, 1).End(xlUp).Row
  30. cSheetCol = 5
  31.  
  32.  
  33. 'unprotect with password if needed
  34.  
  35. 'cTeam.Unprotect "password"
  36.  
  37.  
  38.        
  39. ' loop through row 8 to find columns with name,gender,course,domicile,phones and copy + paste them
  40. With cTeam
  41.  
  42.     For logCol = 1 To 52 Step 1
  43.     colLetter = Split(.Cells(1, logCol).Address, "$")(1)
  44.         If cTeam.Cells(8, logCol).Value Like "*" & "Applicant Name" & "*" Then
  45.             .Range(colLetter & "8" & ":" & colLetter & .Cells(.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
  46.             cSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
  47.         ElseIf cTeam.Cells(8, logCol).Value Like "*" & "Gender" & "*" Then
  48.             .Range(colLetter & "8" & ":" & colLetter & .Cells(.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
  49.             cSheet.Range("B1").PasteSpecial Paste:=xlPasteValues
  50.         ElseIf cTeam.Cells(8, logCol).Value Like "*" & "Programme" & "*" Then
  51.             .Range(colLetter & "8" & ":" & colLetter & .Cells(.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
  52.             cSheet.Range("C1").PasteSpecial Paste:=xlPasteValues
  53.         ElseIf cTeam.Cells(8, logCol).Value Like "*" & "Domicile" & "*" Then
  54.             .Range(colLetter & "8" & ":" & colLetter & .Cells(.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
  55.             cSheet.Range("D1").PasteSpecial Paste:=xlPasteValues
  56.         ElseIf cTeam.Cells(8, logCol).Value Like "*" & "Tel" & "*" Then
  57.             .Range(colLetter & "8" & ":" & colLetter & .Cells(.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
  58.             cSheet.Cells(1, cSheetCol).PasteSpecial Paste:=xlPasteValues
  59.             cSheetCol = cSheetCol + 1
  60.         End If
  61.    
  62.     Next logCol
  63.    
  64. End With
  65.  
  66.  
  67. 'remove formatting
  68.  
  69. cSheet.Cells.ClearFormats
  70.  
  71. 'replace + in phone numbers with 00 never used VBA to replace stuff so just left whatever the macro recorder put out - at some point go back and make this a bit neater
  72.  
  73. Columns("E:J").Replace What:="+", Replacement:="00"
  74. Columns("E:J").Replace What:="-", Replacement:=""
  75. Columns("E:J").Replace What:="(", Replacement:=""
  76. Columns("E:J").Replace What:=")", Replacement:=""
  77. Columns("E:J").Replace What:=" ", Replacement:=""
  78.  
  79.  
  80.        
  81. 'add a formula in adjacent column to join all the phone numbers separated by line breaks
  82. 'used LEN instead of = "" because sometimes the empty phone number will show up as 0 or and have a leading space etc
  83. 'this way this should exclude those cases
  84.  
  85. cSheet.Range("K2").FormulaR1C1 = "=CONCATENATE(IF(AND(RC[-6]="""",RC[-5]="""",RC[-4]="""",RC[-3]="""",RC[-2]="""",RC[-1]=""""), ""No Number"",""""),IF(OR(LEN(RC[-6])<3,RIGHT(RC[-6],6)=RIGHT(RC[-5],6),RIGHT(RC[-6],6)=RIGHT(RC[-4],6),RIGHT(RC[-6],6)=RIGHT(RC[-3],6),RIGHT(RC[-6],6)=RIGHT(RC[-2],6),RIGHT(RC[-6],6)=RIGHT(RC[-2],6)),"""",RC[-6]&CHAR(10)),IF(OR(LEN(RC[-5])<3,RIGHT(RC[-5],6)=RIGHT(RC[-4],6), RIGHT(RC[-5], 6)=RIGHT(RC[-3],6),RIGHT(RC[-5],6)=RIGHT(RC[-2],6),RIGHT(RC[-5],6)=RIGHT(RC[-1],6)),"""",RC[-5]&CHAR(10)), IF(OR(LEN(RC[-4])<3,RIGHT(RC[-4],6)=RIGHT(RC[-3],6),RIGHT(RC[-4],6)=RIGHT(RC[-2],6),RIGHT(RC[-4],6)=RIGHT(RC[-1],6)),"""",RC[-4]&CHAR(10)),IF(OR(LEN(RC[-3])<3,RIGHT(RC[-3],6)=RIGHT(RC[-2],6),RIGHT(RC[-3],6)=RIGHT(RC[-1],6)),"""",RC[-3]&CHAR(10)),IF(OR(LEN(RC[-2])<3,RIGHT(RC[-2],6)=RIGHT(RC[-1],6)),"""",RC[-2]&CHAR(10)),IF(LEN(RC[-1])<3,"""",RC[-1]&CHAR(10)))"
  86. cSheet.Range("K2").AutoFill Destination:=Range("K2:K" & Cells(Rows.Count, 1).End(xlUp).Row)
  87.  
  88. 'copy the new phone numbers into one column as values
  89.  
  90. cSheet.Range("K:K").Copy
  91. cSheet.Range("E:E").PasteSpecial Paste:=xlPasteValues
  92.  
  93. 'clear leftover things after putting all phone numbers in 1 column and add/adjust titles for columns
  94. 'too lazy to do another count of the last used row etc so just clearing the 10k rows and some columns to the right of whats used for callsheet
  95.  
  96. cSheet.Range("F1:Z10000").Clear
  97. cSheet.Range("F1").Value = "Notes"
  98. cSheet.Range("E1").Value = "Phone Numbers"
  99. cSheet.Range("B1").Value = "M/F"
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106. 'autofit everything
  107.  
  108. cSheet.Cells.Columns.AutoFit
  109. cSheet.Cells.Rows.AutoFit
  110. cSheet.Cells.HorizontalAlignment = xlLeft
  111. cSheet.Cells.VerticalAlignment = xlTop
  112.  
  113. 'add borders, adjust row and column sizes, allow wrap text
  114.  
  115. cSheet.Range("A2:F" & Cells(Rows.Count, 1).End(xlUp).Row).Borders.LineStyle = xlContinuous
  116. cSheet.Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).RowHeight = 56.6
  117. cSheet.Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).ColumnWidth = 14
  118. cSheet.Range("C2:C" & Cells(Rows.Count, 1).End(xlUp).Row).ColumnWidth = 20
  119. cSheet.Range("D2:D" & Cells(Rows.Count, 1).End(xlUp).Row).ColumnWidth = 12
  120. cSheet.Range("F2:F" & Cells(Rows.Count, 1).End(xlUp).Row).ColumnWidth = 60
  121. cSheet.Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).WrapText = True
  122. cSheet.Range("C2:C" & Cells(Rows.Count, 1).End(xlUp).Row).WrapText = True
  123. cSheet.Range("E2:E" & Cells(Rows.Count, 1).End(xlUp).Row).WrapText = True
  124. cSheet.Range("D2:D" & Cells(Rows.Count, 1).End(xlUp).Row).WrapText = True
  125. cSheet.Range("E:E").Columns.AutoFit
  126.  
  127. 'add title in merged 1st row cols A to F + todays date
  128.  
  129. Dim title As String
  130. Dim today As String
  131.  
  132. today = Day(Date) & "/" & Month(Date) & "/" & Year(Date) ' bind todays date to variable
  133. title = InputBox("Please put in a description of the call sheet that would appear on the top of the 1st page of the call sheet and is optional. Todays date will be automatically added to the end of the description." & vbCrLf & "Otherwise leave blank")
  134.  
  135. If title <> "" Then
  136.         Range("A1").EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
  137.         Range("A1:F1").Merge
  138.     With Range("A1") 'not sure how VBA records merged cells so just gonna stick with selection rather than referencing a range until i get around to looking this up
  139.        .Value = title & " " & today ' add todays date to the title
  140.        .HorizontalAlignment = xlLeft 'align title left
  141.        .Font.Bold = True
  142.         .Font.Size = 12
  143.     End With
  144.     cSheet.Rows(2).AutoFit
  145. End If
  146.  
  147. 'set up print area, change orientation to landscape and make margins narrow
  148.  
  149.  
  150.  
  151. With cSheet.PageSetup
  152.     .PrintArea = cSheet.Range("A1:F" & Cells(Rows.Count, 1).End(xlUp).Row).Address
  153.     .Orientation = xlLandscape
  154.     .LeftMargin = Application.InchesToPoints(0.25)
  155.     .RightMargin = Application.InchesToPoints(0.25)
  156.     .TopMargin = Application.InchesToPoints(0.75)
  157.     .BottomMargin = Application.InchesToPoints(0.75)
  158.     .HeaderMargin = Application.InchesToPoints(0.3)
  159.     .FooterMargin = Application.InchesToPoints(0.3)
  160. End With
  161.  
  162.  
  163. 'exit cutcopymode and enable screenupdating again
  164. Application.CutCopyMode = False
  165. Application.ScreenUpdating = True
  166. Application.DisplayAlerts = True
  167. cSheet.Range("A1").Select
  168.  
  169.  
  170. 'protect with password if needed
  171.  
  172. 'cTeam.Protect "password", DrawingObjects:=True, Contents:=True, Scenarios:=True _
  173. '       , AllowFormattingCells:=True, AllowFormattingColumns:=True, _
  174. '       AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
  175. '        :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
  176. '        AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
  177. '        AllowUsingPivotTables:=True
  178. '    cTeam.EnableSelection = xlUnlockedCells
  179.  
  180.  
  181. End Sub
  182.  
  183.  
  184. Sub replace_text()
  185.  
  186. Dim str As String
  187. Dim c As Range
  188.  
  189. str = InputBox("Please input text you would like added to the end of the selected cells")
  190.  
  191.  
  192. For Each c In Selection
  193.     If c.Value = "" And c.EntireRow.Hidden = False Then
  194.         c.Value = str
  195.     ElseIf c.Value <> "" And c.EntireRow.Hidden = False Then
  196.         c.Value = c.Value & " " & str
  197.     End If
  198. Next c
  199.  
  200.    
  201.  
  202. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!