I have a Word document based on a template for invoices and a database in Excel containing two tables: Company and Person.
I want to put some string into the textbox in the userform in Word which will then be searched in Excel. Excel shall return the values to a MultiColumn-Listbox located in another UserForm (this userform will only show if there is more than 1 result for the searched string).
This is the code I have in Word to run the macro, which actually gets started:
CSearchText = UFCompanySearch.tbSearchCompany.Value 'Textbox -> Search-String
xlWB.Application.Run("SearchCompany")
This only works when SearchCompany is a sub or a function with no further specifications, so
Function SearchCompany(SearchText As String)
doesn't work as I cannot run the Macro as follows:
xlWB.Application.Run("SearchCompany("SomeCompany")") 'NOTE!
NOTE: This will NOT work!!
To fill the Listbox in the UserForm I think there is the possibility to fill it with an Excel table, so this should somehow work out.
THIS is the PROBLEM:
I cannot refer to the Search-TextBox in the Userform which is located in the word Document as neither "Doc!" nor "Doc." works. Like this I can't search the cells for the string. This is the code I have to find cells containing the string:
IF (InStr(xlComp.Cells(Row, 1), CSearchText) > 0) Or _
(InStr(xlComp.Cells(Row, 2), CSearchText) > 0) Or _
(InStr(xlComp.Cells(Row, 3), CSearchText) > 0) Then
This searches the Columns A-C for the entered string. (Code I found somewhere... I have been searching too much to know where from ^.^)
Is there a way to address the UserForm in Word or a workaround to get the "SearchText" from the userform to Excel?
I'm quite new in VBA, so the more detailed your answer the more probable I will understand it.
As I did not find a way to do it directly I got a workaround when trying:
Code in Word:
Private Sub cbFirmaSearch_Click()
ActiveDocument.FormFields("FSearchText").Result = UFFirmaSearch.txtFirmaSuchen.Value
xlWB.Application.Run "SearchFirma"
ActiveDocument.FormFields("FSearchText").Delete
Dim DFLastRow As Integer
DFLastRow = xlWB.Sheets("DataFirma").Cells(xlWB.Sheets("DataFirma").Rows.Count, "a").End(xlUp).Row
Dim lbFirmTar As ListBox
Set lbFirmTar = UFFirmaSearchList.lbFirmaSearchList
Dim Row As Integer
For Row = 2 To DFLastRow
With lbFirmTar
Dim ListIndex As Integer
ListIndex = UFFirmaSearchList.lbFirmaSearchList.ListCount
.AddItem xlWB.Sheets("DataFirma").Cells(Row, 1).Value, ListIndex
.List(ListIndex, 1) = xlWB.Sheets("DataFirma").Cells(Row, 2).Value
.List(ListIndex, 2) = xlWB.Sheets("DataFirma").Cells(Row, 3).Value
.List(ListIndex, 3) = xlWB.Sheets("DataFirma").Cells(Row, 4).Value
.List(ListIndex, 4) = xlWB.Sheets("DataFirma").Cells(Row, 5).Value
.List(ListIndex, 5) = xlWB.Sheets("DataFirma").Cells(Row, 6).Value
.List(ListIndex, 6) = xlWB.Sheets("DataFirma").Cells(Row, 7).Value
End With
Next Row
With UFFirmaSearchList
If (.lbFirmaSearchList.ListCount > 1) Then
UFFirmaSearch.Hide
.Show
ElseIf (.lbFirmaSearchList.ListCount = 1) Then
FirmaID = .lbFirmaSearchList.List(0, 0)
FirmaZusatz = .lbFirmaSearchList.List(0, 1)
FirmaName = .lbFirmaSearchList.List(0, 2)
FirmaAbteilung = .lbFirmaSearchList.List(0, 3)
FirmaAdresse = .lbFirmaSearchList.List(0, 4)
FirmaPLZ = .lbFirmaSearchList.List(0, 5)
FirmaOrt = .lbFirmaSearchList.List(0, 6)
UFFirmaSearch.lblfrFirmenangaben = "Firma ID : " & FirmaID & _
"Firmenzusatz : " & FirmaZusatz & _
"Name : " & FirmaName & _
"Firmenabteilung : " & FirmaAbteilung & _
"Adresse : " & FirmaAdresse & _
"PLZ / Ort : " & FirmaPLZ & " " & FirmaOrt
Else
MsgBox "No Entry found.", vbOKOnly
End If
End With
UFFirmaSearch.txtFirmaSuchen.SetFocus
End Sub
Code in Excel:
Sub SearchFirma()
Dim Doc As Word.Document
Set Doc = ActiveDocument
Dim xlFirm As Worksheet
Set xlFirm = ActiveWorkbook.Sheets("Firma")
Dim LastRow As Integer 'Last row on sheet "Firma" containing values
LastRow = xlFirm.Cells(xlFirm.Rows.Count, "a").End(xlUp).Row
Dim xlDatFirm As Worksheet
Set xlDatFirm = ActiveWorkbook.Sheets("DataFirma")
Dim FSearchText As String
FSearchText = Doc.FormFields("FSearchText").Result
For Row = 2 To LastRow
Dim DFNewRow As Integer 'Next free line on sheet "DataFirma"
DFNewRow = xlDatFirm.Cells(xlDatFirm.Rows.Count, "A").End(xlUp).Row + 1
If (InStr(1, xlFirm.Cells(Row, 1), FSearchText, vbTextCompare) > 0) Or (InStr(1, xlFirm.Cells(Row, 2), FSearchText, vbTextCompare) > 0) Or (InStr(1, xlFirm.Cells(Row, 3).Value, FSearchText, vbTextCompare) > 0) Or (InStr(1, xlFirm.Cells(Row, 4).Value, FSearchText, vbTextCompare) > 0) Then
xlDatFirm.Range("A" & DFNewRow).Value = xlFirm.Cells(Row, 1).Value
xlDatFirm.Range("B" & DFNewRow).Value = xlFirm.Cells(Row, 2).Value
xlDatFirm.Range("C" & DFNewRow).Value = xlFirm.Cells(Row, 3).Value
xlDatFirm.Range("D" & DFNewRow).Value = xlFirm.Cells(Row, 4).Value
xlDatFirm.Range("E" & DFNewRow).Value = xlFirm.Cells(Row, 5).Value
xlDatFirm.Range("F" & DFNewRow).Value = xlFirm.Cells(Row, 6).Value
xlDatFirm.Range("G" & DFNewRow).Value = xlFirm.Cells(Row, 7).Value
End If
Next Row
End Sub
Somehow this works. When I first tried "Dim xlWB As Excel.Workbook" in Word I would always get a runtime error. When I tried "Dim Doc As Word.Document" in Excel though I never got an error... very strange but still somehow managed to get it over with.
If you have any questions regarding this I will be happy to try to help and if there are things that I can rewrite in a better way, please don't hesitate to comment.
Thanks for the support :)
Related
I have a code as below. there are 2 workbooks I have used. one of them is taking the data from system and the other workbook is filled by users manually.
code is combining 2 columns on both workbooks and search for the data on 2nd workbook. if matchs, adding the data, which is in 1st workbook, to workbook 2.
unless there is another column need to be added this code. but there is an issue, 3rd column on workbook 2 can have typo mistakes or shorten versions of the words.
so, user need to decide which cell need to be filled.
for example ;
so below macro directly find and adding the data to 1st and 4th rows. but I know the data need to be added on only 4th row because user can understand tt means on 2nd workbook column 3 is Turk Telekom. so I need a msgbox addition to ask user column 3 is xx do you want to add, and also ask on 4th row column 3 is tt do you want to add.
findstring1 = wb.Sheets("Sheetname").Range("E4").Value
findstring2 = wb.Sheets("sheetname").Range("E5").Value
firstrow = 2
lastcell = s.Cells(2, 1).End(xlDown).Row
For i = firstrow To lastcell
If Left(s.Cells(i, 3), 3) = findstring1 And s.Cells(i, 4) = findstring2 Then
If s.Cells(i, 21) = "" Then
s.Cells(i, 21) = wb.Sheets("sheetname").Range("I4")
Else
s.Cells(i, 22) = s.Cells(i, 22).Value & " done on " & wb.Sheets("sheetname").Range("I4") & "."
End If
End If
Next i
firstrow = 2
lastcell = s.Cells(2, 1).End(xlDown).Row
For i = firstrow To lastcell
If Left(s.Cells(i, 3), 3) = findstring1 And s.Cells(i, 4) = findstring2 Then
Dim myReply As Integer
myReply = MsgBox("Matched code is as below. Would you like to Continue? [YES] Or Not [NO] ?" & " " & s.Cells(i, 6), _
vbYesNo + vbQuestion, "code Check")
Select Case myReply
Case Is = vbYes
Application.Cursor = xlWait
If s.Cells(i, 21) = "" Then
s.Cells(i, 21) = wb.Sheets("sheetname").Range("I4")
Else
s.Cells(i, 22) = s.Cells(i, 22).Value & " bla bla bla " & wb.Sheets("sheetname").Range("I4") & "."
End If
Case Is = vbNo
End Select
End If
Next i
worked for me
1) Write a statement in excel that will insert rows and fill missing data for days missing any hour. Hours in “DATE_HR” should go from 00-23 (24 hour time).
And
2) For hours that are listed, under “DATE_HR” (DD-MMM-YYYY-HH), that are missing “0” (which is NDG in “Class”) “1-4”, “GR”, and/or “SB” in “CLASSIFICATION”, for any given hour, write a statement that will insert and fill missing rows in all hours that has the missing “CLASSIFICATION”, “Class”, “DATE_HR”, AND “Total” (which missing “TOTAL” row values should be zero since there was no entry for the missing data).
Below is an example of what the program needs to do. The left is the missing data table (before) and the right is the corrected table (after), Yellow is 1 and blue is 2
-Here is my progress up to now:
I have written pseudo code for the issue and have started writing at in excel VBA. Here is the pseudo code:
SR = Selected_row
RA = Row_above
C = Classification
DT = Date & Time
IR=Insert_row
# = Any number 1-4
Start on seleted row
Loop statement:
= IF(SRC = ”GR” AND RAC = 4 AND SRDT== RADT, SR,
OR(SRC = ”SB” AND RAC = “GR” AND SRDT== RADT, SR,
OR(SRC = 0 AND RAC = “SB” AND SRDT== RADT -1day/+22hour, SR,
OR(SRC = # AND RAC = SRC -1 AND SRDT == RADT, SR,
OR(SRC = 0 AND RADT = -1day of SRC/23hour, SRC = “0” AND SRDT= RADT +1day/00hour,IR AND
IF(RAC = ”SB” AND RADT = 23hour, SRC = “0” AND SRDT= RADT +1day/00hour,
OR (RAC = ”SB”, SRC = “0” AND SRDT= RADT +1hour,
OR (RAC = ”GR”, SRC = “SB” AND SRDT= RADT,
OR (RAC = 4, SRC = “GR” AND SRDT= RADT,
OR(RAC = # AND SRC = RAC +1 AND SRDT == RADT, SR *here # = 0-3
)))))))))))))
Move onto next row below previous row
IF(SR=””, END program, continue)
Here is the excel VBA code: (the colors are just it see if it’s doing what it should)
Sub IF_Loop()
Dim i As Long
For i = 2 To 155
If (Range("B" & i).Value = "GR" And Range("B" & i - 1).Value = 4 And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
(Range("B" & i).Value = "SB" And Range("B" & i - 1).Value = "GR" And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
(Range("B" & i).Value = "4" And Range("B" & i - 1).Value = "3" And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
(Range("B" & i).Value = "3" And Range("B" & i - 1).Value = "2" And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
(Range("B" & i).Value = "2" And Range("B" & i - 1).Value = "1" And Range("C" & i).Value = Range("C" & i - 1).Value) Or _
(Range("B" & i).Value = "1" And Range("B" & i - 1).Value = "00" And Range("C" & i).Value = Range("C" & i - 1).Value) Then
Rows(i & ":" & i).Interior.Color = 9359529
Else
'insert row and correct data
Rows(i & ":" & i).EntireRow.Insert shift:=x1Down And _
Rows(i & ":" & i)
End If
Next i
I’m not sure how to write the remaining code. How do you properly write the remaining lines so the code will execute the tasks that are needed?
I would do this differently.
You need to know your starting and ending dates, and you also need to have a list of ALL of the Classifications and the associated Classes. (I hard coded both within the macro, but you can use other schemes).
From that you can create a table with all of the classes and all of the hours for all of the dates.
Once you've done that, you can look up to see if the Totals are available for the classification/date combination, and either write that in, or, if not present, a zero.
I used a class object which contains the information. Each of these objects has a collection (dictionary) of all the date_hr | total combinations available for that classification, and also a method to return the class for a given classification.
Working with VBA arrays is orders of magnitude faster than multiple read/writes to/from worksheets.
I hopefully have commented the code enough so you can understand what is going on.
For an excellent discussion of class objects, see the late Chip Pearsons Introduction to Classes. If this link dies, you'll need to do a web search. There is also an article there on reading/writing arrays to/from worksheet ranges which you will find useful.
Read the comments, especially at the beginning of each module, carefully so as to properly set things up, otherwise, it won't run.
It does assume that your data has a header row, and starts in A1.
The results are placed on the same worksheet, but it should be obvious how to change that.
Class Module
'**Rename this module: cClass**
Option Explicit
Private pClass As String
Private pClassification As String
Private pDate_HR As Date
Private pDate_HRs As Dictionary
Public Property Get class() As String
Select Case Me.Classification
Case "1"
class = "Freshman"
Case "2"
class = "Sophomore"
Case "3"
class = "Junior"
Case "4"
class = "Senior"
Case "GR"
class = "Graduate"
Case "SB"
class = "Second Bachelor"
Case "0"
class = "NDG"
Case Else
class = "N/A"
End Select
End Property
Public Property Get Classification() As String
Classification = pClassification
End Property
Public Property Let Classification(Value As String)
pClassification = Value
End Property
Public Property Get Date_HR() As Date
Date_HR = pDate_HR
End Property
Public Property Let Date_HR(Value As Date)
pDate_HR = Value
End Property
Public Property Get Date_HRs() As Dictionary
Set Date_HRs = pDate_HRs
End Property
Public Function addDate_HRsItem(dtHR As Date, toTAL As Long)
Date_HRs.Add Key:=dtHR, Item:=toTAL
End Function
Private Sub Class_Initialize()
Set pDate_HRs = New Dictionary
pDate_HRs.CompareMode = TextCompare
End Sub
Regular Module
Option Explicit
'set reference to microsoft scripting runtime
Sub fillData()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim I As Long, J As Long
Dim dD As Dictionary, cc As cClass
Dim sKey As String, sDTkey As Date
'set source and results worksheets, range
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet1")
Set rRes = wsRes.Cells(1, 7)
'read source data into vba array
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
End With
'Process the known data
'collect it into a dictionary for fast lookups
Set dD = New Dictionary
dD.CompareMode = TextCompare
For I = 2 To UBound(vSrc, 1)
Set cc = New cClass
With cc
.Classification = vSrc(I, 1)
.Date_HR = convDTHR(vSrc(I, 3))
.addDate_HRsItem .Date_HR, CLng(vSrc(I, 4))
sKey = .class
If Not dD.Exists(sKey) Then
dD.Add sKey, cc
Else
dD(sKey).addDate_HRsItem .Date_HR, CLng(vSrc(I, 4))
End If
End With
Next I
'Create Results Array
'Unclear from your question how many dates you want, so will
' just do Mar 4
Const dtStart As Date = #3/4/2019#
Const dtEnd As Date = #3/5/2019#
'code the list of all Classifications
Dim arrClass
arrClass = Array(0, 1, 2, 3, 4, "GR", "SB")
ReDim vRes(0 To (dtEnd - dtStart + 1) * 24 * (UBound(arrClass) + 1), 1 To 4)
'write the column Headers into a results array
For J = 1 To 4
vRes(0, J) = vSrc(1, J)
Next J
'fill in other columns
For I = 1 To UBound(vRes, 1) Step UBound(arrClass) + 1
For J = 0 To UBound(arrClass)
vRes(I + J, 1) = arrClass(J) 'Classification
vRes(I + J, 2) = convCLASS(arrClass(J)) 'class
vRes(I + J, 3) = Format(dtStart + Int((I + J - 1) / (UBound(arrClass) + 1)) / 24, "dd-mmm-yyyy hh") 'The Date_hr
sKey = vRes(I + J, 2) 'key into dictionary
If dD.Exists(sKey) Then
sDTkey = convDTHR(vRes(I + J, 3)) 'key into collection of date/totals within the dictionary item
If dD(sKey).Date_HRs.Exists(sDTkey) Then
vRes(I + J, 4) = dD(sKey).Date_HRs(sDTkey)
Else
vRes(I + J, 4) = 0
End If
Else
vRes(I + J, 4) = 0
End If
Next J
Next I
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.Columns(1).HorizontalAlignment = xlCenter
.EntireColumn.AutoFit
End With
End Sub
Private Function convDTHR(strDTHR) As Date
convDTHR = CDate(Left(strDTHR, 11)) + Right(strDTHR, 2) / 24
End Function
Private Function convCLASS(strClassification) As String
Dim cc As cClass
Set cc = New cClass
With cc
.Classification = strClassification
convCLASS = .class
End With
End Function
One of our spreadsheets requires a userform. When trying to paste the user's values to the sheet housing the data, I get error code 13: type mismatch.
All the fields are textboxes. One line of code identical except the address of where we're posting the information works.
Here's what I have:
Public Sub btnSubmit_Click()
Dim TableSht As Worksheet
Dim NextRow As Long
Set TableSht = ThisWorkbook.Sheets("Table")
TableSht.Visible = True
'https://www.mrexcel.com/forum/excel-questions/1017033-making-all-fields-userform-mandatory.html#post4880848
'determine if any fields were left blank
For Each Control In Me.Controls '
Select Case TypeName(Control)
Case "TextBox"
If Control.Value = vbNullString Then
MsgBox "empty field in " & Control.Name
Exit For
End If
Case Else
End Select
Next Control
'data is housed in E3:J3, E5:J5, E7:J7, E9:J9. if statement determines what row information
'should be entered on.
If TableSht.Range("E3") = "" Then
NextRow = 3
ElseIf TableSht.Range("E5") = "" Then
NextRow = 5
ElseIf TableSht.Range("E7") = "" Then
NextRow = 7
ElseIf TableSht.Range("E9") = "" Then
NextRow = 9
Else
MsgBox ("There are no more available rows. Contact Craig for additional assistance.")
End If
'paste the user's data entry into the appropriate cells
With TableSht
.Cells(NextRow, 5) = Me.tbOwner
.Cells(NextRow, 6) = CDate(Me.tbDate)
.Cells(NextRow, 7) = Me.tbChange
'Me.tbChange.Value = CDec(Me.tbChange) 'no longer use this but one of my attempts
.Cells(NextRow, 8) = Me.tbAmount
.Cells(NextRow, 9) = Me.tbOriginal
.Cells(NextRow, 10) = Me.tbReason
.Cells(NextRow, 7).Value = Format(Range("G" & NextRow) / 100, "0.00%")
.Cells(NextRow, 8).Value = Format(Range("H" & NextRow), "$##.##")
.Cells(NextRow, 9).Value = Format(Range("I" & NextRow) / 100, "0.00%")
End With
Sheets("Rate Calculator v8").Select
TableSht.Visible = xlVeryHidden
Unload Me
End
End Sub
The error occurs on
.Cells(NextRow, 7).Value = Format(Range("G" & NextRow) / 100, "0.00%")
There's no error if I remove the line and cycle through the two after it, even though the last line before "end with" is essentially the same statement.
I've tried swapping the two lines of code that are similar. "Cells(NextRow, 7)..." and ".Cells(NextRow, 9)..." but the error still shows up on the "Cells(NextRow, 7)..." line.
I've confirmed the cells the data is pasted in columns G and I are both formatted as "percentage".
Qualify your Range usage with a sheet. If the sheet is also TableSht, the below should work. If the Range is from a different sheet, qualify that sheet
= Format(.Range("G" & NextRow) / 100, "0.00%")
= Format(.Range("H" & NextRow), "$##.##")
= Format(.Range("I" & NextRow) / 100, "0.00%")
I have a big table in excel, which contains about 8000 rows of data. I am working on a procedure to enable the users to receive a pdf copy of what they are looking for. (A detail list related to a work order).
I tried two different approaches, first copying the work order items after filtering it to a third sheet and then copying selected fields of data to the final form. It was good and fast.
second, after filter directly copying data of unhidden rows to the final form. (also more sort and remove duplicated items happen too)
The second one is very time killing (3 to 5 minutes) and very heavy.
Now, I am thinking of first sorting the data in a way that my desired item (what the user is looking for) comes to the first of table so after the filter, I just ask the loop to go until a visible number of rows, not until the end of rows.
Has anyone any idea, or better solution?
Cheers and merry Christmas!
Sub kit_Click()
' On Error GoTo Errorhandler
Dim wc As String
Dim c As Integer
Dim tbl As Range
Dim sel As Range
Dim des As Range
Dim m As Integer
Dim j As Integer
Dim aggrow As Integer
Dim varResult As Variant
Dim kf As Worksheet
Set kf = Worksheets("Kit Form")
a = ""
' Application.ScreenUpdating = False
' finding W/B code to prepare
If Not Intersect(ActiveCell, Range("d2:d3")) Is Nothing Then
a = Cells(2, 7).Value
GoTo body
ElseIf ActiveCell.Row < 6 Then a = InputBox("please specify the W/B you want to prepare KIT form for that", "W/B Number")
ElseIf ActiveCell.Row > ActiveSheet.UsedRange.Rows.Count Then a = InputBox("please specify the W/B you want to prepare KIT form for that", "W/B Number")
Else: a = Cells(ActiveCell.Row, 2).Value
End If
body:
On Error GoTo skip
wc = WorksheetFunction.VLookup(a, Range("b5:c1000"), 2, 0)
skip:
If a = "" Or a = "0" Then
a = InputBox("please specify the W/B you want to prepare KIT form for that", "W/B Number")
Else
' Cleaning KIT FORM
If Not kf.ListObjects("KitForm").DataBodyRange Is Nothing Then kf.ListObjects("KitForm").DataBodyRange.EntireRow.Delete
' Filtering the W/B Kittable items
With Sheets("FTV3")
.Range("tbl").AutoFilter Field:=3, Criteria1:="*" & a & "*", Operator:=xlFilterValues
.Range("tbl").AutoFilter Field:=25, Criteria1:="OK", Operator:=xlFilterValues
' Unhidding the Columns and copying the header row
.Cells.EntireColumn.Hidden = False
' Copying the data to Form
lstrw = .Cells(Rows.Count, 8).End(xlUp).Row
kf.Cells(2, 2) = a
kf.Cells(1, 4) = wc
m = 1
For i = 2 To lstrw
If .Rows(i).EntireRow.Hidden Then
m = m + 1
Else
kf.Rows(i - m + 4).RowHeight = 25
kf.Cells(i - m + 4, 1).Value = i - m
If .Cells(i, 21).Value = "_N/A" Then
kf.Cells(i - m + 4, 2) = "'"
Else
kf.Cells(i - m + 4, 2) = .Cells(i, 21)
End If
kf.Cells(i - m + 4, 3).Value = .Cells(i, 4).Value
If .Cells(i, 4).Value <> "_Book" Then kf.Cells(i - m + 4, 4).Value = .Cells(i, 26).Value
Worksheets("Kit Form").Cells(i - m + 4, 5).Value = .Cells(i, 7).Value
If .Cells(i, 8).Value <> "N/T" Then kf.Cells(i - m + 4, 6).Value = .Cells(i, 8).Value
If .Cells(i, 12).Value <> "_N/A" Then ttt = .Cells(i, 12) 'Or .Cells(i, 22).Value <> ""
kf.Cells(i - m + 4, 7).Value = "(( " & .Cells(i, 27).Value & " ))" & Chr(10) & ttt
kf.Rows(i - m + 4).AutoFit
If kf.Rows(i - m + 4).RowHeight < 25 Then kf.Rows(i - m + 4).RowHeight = 25
End If
Next
.Range("A:B,S:ac").EntireColumn.Hidden = True
aggrow = kf.Cells(Rows.Count, 1).End(xlUp).Row - 4
.Range("tbl").AutoFilter
End With
Call remove_duplicate
R = MsgBox("Successfuly Total of " & lstrw - m - 1 & " Items, aggregated in " & aggrow & " Rows of material Copied to the Kit Form " & Chr(10) & Chr(10) & "Do you want an PDF version of The form being prepared for you?", vbYesNo, "Result")
If R = 6 Then Call export_pdf
End If
End Sub
This is probably something quite obvious, but I have done quite a bit of googling to no avail.
First of all I am more than happy if you have a more succinct way of doing this, I am always keen to learn - this is the best way I could think of to achieve the task.
Basically, once the columns are found I will be transferring data from another sheet that will go at the end of Range(xlDown) and offset by 1 etc.
But at the moment, if i run this as For 1 to 6 it works fine, if I run for 1 to 7 it gives the error but everything is defined in the same way. strSoS is defined, but rngSoS always shows as 'Nothing' even though the other cells work fine?
Columns 1 to 7 have the 7 titles (as stated) in the list of String declarations, the reason it is done this way is that the sheet data will be coming from may have extra columns that wont be required.
Hope you can help solve my issue!
Sub ColumnSearch()
Dim strDoN, strOffice, strARN, strPIN, strAN, strAT, strSoS As String
Dim rngDoN, rngOffice, rngARN, rngPIN, rngAN, rngAT, rngSoS As Range
Dim myRange As Range
Dim NumCols, i As Integer
strDoN = "Date of Notification"
strOffice = "Office Centre"
strARN = "Appeal Reference Number"
strPIN = "PIN"
strAN = "Appellant Name"
strAT = "Appeal Type"
strSoS = "SoS Decision Date"
For i = 1 To 7
If Cells(1, i).Value = strDoN Then
rngDoN = Cells(1, i).Address(False, False)
ElseIf Cells(1, i).Value = strOffice Then
rngOffice = Cells(1, i).Address(False, False)
ElseIf Cells(1, i).Value = strARN Then
rngARN = Cells(1, i).Address(False, False)
ElseIf Cells(1, i).Value = strPIN Then
rngPIN = Cells(1, i).Address(False, False)
ElseIf Cells(1, i).Value = strAN Then
rngAN = Cells(1, i).Address(False, False)
ElseIf Cells(1, i).Value = strAT Then
rngAT = Cells(1, i).Address(False, False)
ElseIf Cells(1, i).Value = strSoS Then
rngSoS = Cells(1, i).Address(False, False)
End If
Next i
MsgBox rngDoN & rngOffice & rngARN & rngPIN & rngAN & rngAT & rngSoS
End Sub
You are trying to stuff a string address (text) into an unassigned Range object.
Dim strDoN, strOffice As String, strARN As String, strPIN As String
Dim strAN As String, strAT As String, strSoS As String
Dim rngDoN As Range, rngOffice As Range, rngARN As Range
Dim rngPIN As Range, rngAN As Range, rngAT As Range, rngSoS As Range
For i = 1 To 7
Select Case Cells(1, i).Value
Case strDoN
Set rngDoN = Cells(1, i) '<~~ set the range object to this cell
Case strOffice
Set rngOffice = Cells(1, i)
Case strARN
Set rngARN = Cells(1, i)
Case strPIN
Set rngPIN = Cells(1, i)
Case strAN
Set rngAN = Cells(1, i)
Case strAT
Set rngAT = Cells(1, i)
Case strSoS
Set rngSoS = Cells(1, i)
Case Else
'no match - do nothing
End Select
Next i
MsgBox rngDoN.Address(0, 0) & Chr(9) & rngOffice.Address(0, 0) & Chr(9) & _
rngARN.Address(0, 0) & Chr(9) & rngPIN.Address(0, 0) & Chr(9) & _
rngAN.Address(0, 0) & Chr(9) & rngAT.Address(0, 0) & Chr(9) & _
rngSoS.Address(0, 0)
Your narrative is a little short on what you actually want to accomplish. I've set the range objects to the matching cells and returned their addresses to the message box.
The rngSoS was failing because it is the only one actually declared as a range-type variable.