Attempting to Index Match Match using VBA and failing - excel

I am attempting to identify the row and column of which the intersection is the data I want to retrieve, much like an index match match formula in Excel. My method is find the data in the column, get the column letter, and do the same with the data in the row and retrieve the row number. The problem I am having is that I have to reference a cell in a separate workbook where the macro is located to open another spreadsheet's name that changes with the month. I'm sure this whole thing's method is not very good, advice would be appreciated!
Option Explicit
Sub RevenueTest()
'GVS1 Revenue Index Match Test
'DELETES & COPIES GVS1 revenue into P&R File
Dim GVS1 As String
GVS1 = ThisWorkbook.Sheets("Revenue").Range("v13")
Dim GVS1IS As String
GVS1IS = ThisWorkbook.Sheets("Revenue").Range("V7")
Dim GVS1Open As String
GVS1Open = Excel.Workbooks.Open(GVS1)
Dim Row As String
Row = Range("B5:B25").Find("Generation").Select.ActiveCell.Row
Dim Month As String
Month = ThisWorkbook.Sheets("Revenue").Range("V4")
Dim MonthActual As String
MonthActual = Month & " Actual"
Dim Column As String
Column = Range("A1:P15").Find(MonthActual).Select.ActiveCell.Column
Dim GVS1RowAndColumn As String
GVS1RowAndColumn = Column & Row
'OPENS / Indexes and Copies Revenue
Excel.Workbooks.Open (GVS1)
Columns("C:Q").EntireColumn.Delete
Range(GVS1RowAndColumn).Copy
'PASTES GVS1 revenue into P&R File
Dim Revenue As Worksheet
Set Revenue = ThisWorkbook.Sheets("Revenue")
ThisWorkbook.Activate
Revenue.Range("D3:D11").Find("Revenue").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 1).Range("A1").PasteSpecial xlPasteValues
End Sub

I'm not sure if I properly understood this line
My method is find the data in the column, get the column letter, and do the same with the data in the row and retrieve the row number.
But I do have a similar index match function in my stock, take a look and modify it to your needs.
Option Explicit
Sub Return_value()
Dim Rmrks As Range, Itm_Rng As Range
Dim ItmLstPR As Range, ItmLstCode As Range
On Error Resume Next
With Application
.EnableEvents = False
.ScreenUpdating = False
'they are table range btw like, "tabe_name[column_name]"
'in this range the return value will be pasted
Set Rmrks = .Range("Pip_Line[Remarks]")
'this range has the key word that needs to be matched
Set Itm_Rng = .Range("Pip_Line[Item_Code]")
' from "DMY_Pip_Line[Remarks]" range matched value will be returned
Set ItmLstPR = .Range("DMY_Pip_Line[Remarks]")
'we use "DMY_Pip_Line[Item_Code]" to match our keyword from "Pip_Line[Item_Code]" range
Set ItmLstCode = .Range("DMY_Pip_Line[Item_Code]")
'Return Remarks
Call Match_Value(ItmLstPR, Itm_Rng, ItmLstCode, Rmrks)
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
you can insert above code in a worksheet or in a module.
Paste below code in a module to get the final result.
Option Explicit
Public Sub Match_Value(ByVal ReturnVal As Range, ByVal LookupVal As Range, ByVal LookupRng As Range, ByVal PasteRng As Range)
Dim rng As Range, ResultRow As Long, foundcell As Range, ColmnDist As Long, FoundVal As String
'find column offset
ColmnDist = ReturnVal.Column - LookupRng.Column
ResultRow = PasteRng.Column - LookupVal.Column
On Error Resume Next
For Each rng In LookupVal
'return due placing location row
Set foundcell = LookupRng.Find(rng.Value, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True)
'return value
FoundVal = foundcell.Offset(0, ColmnDist).Value
If Not foundcell Is Nothing And FoundVal <> vbNullString Then
rng.Offset(0, ResultRow).Value = FoundVal
End If
Next
End Sub

In order to understand your code I have rearranged it. In order for you to understand your code I have commented it. To be clear: this is your code, unchanged! We just study.
Sub RevenueTest()
'GVS1 Revenue Index Match Test
'DELETES & COPIES GVS1 revenue into P&R File
Dim Revenue As Worksheet
Dim GVS1 As String
Dim GVS1IS As String
Dim GVS1Open As String
Dim Row As String ' "Row" is an Excel object
Dim Month As String
Dim MonthActual As String
Dim Column As String ' "Column" is an Excel object
Dim GVS1RowAndColumn As String
GVS1 = ThisWorkbook.Sheets("Revenue").Range("V13")
GVS1IS = ThisWorkbook.Sheets("Revenue").Range("V7")
GVS1Open = Excel.Workbooks.Open(GVS1) ' the workbook is an object: can't assign to String
' "ActiveCell.Row" is a number: why assign to a string variable?
' "Row" is an object: can't be the name of a variable
' don't select anything: create a range object instead
' "Find" returns a range object if successful
' if unsuccessful attempting to access that range must fail
' since you don't specify any sheet, 'Range("B5:B25")' is presumed
' to be on the ActiveSheet
Row = Range("B5:B25").Find("Generation").Select.ActiveCell.Row
Month = ThisWorkbook.Sheets("Revenue").Range("V4")
MonthActual = Month & " Actual"
Column = Range("A1:P15").Find(MonthActual).Select.ActiveCell.Column
GVS1RowAndColumn = Column & Row
'OPENS / Indexes and Copies Revenue
Excel.Workbooks.Open GVS1 ' don't enclose arguments in parentheses
Columns("C:Q").EntireColumn.Delete ' columns are in the ActiveSheet
Range(GVS1RowAndColumn).Copy ' Range is on the ActiveSheet
'PASTES GVS1 revenue into P&R File
Set Revenue = ThisWorkbook.Sheets("Revenue")
ThisWorkbook.Activate ' no need to activate anything
Revenue.Range("D3:D11").Find("Revenue").Select ' no need to select anything
Selection.End(xlToRight).Select '
ActiveCell.Offset(0, 1).Range("A1").PasteSpecial xlPasteValues
End Sub
Then I tried to re-write your code so that it might work. You can see how far I got. Look for the specification of the search ranges. They are on the ActiveSheet. Which is the ActiveSheet? We have no clue. But the code shows you how to approach the subject.
Sub RevenueTest_2()
Dim GVS1Book As Workbook
Dim Revenue As Worksheet
Dim Fnd As Range ' result of 'Find'
Dim R As Long ' a row number
Dim C As Long ' a column number
Dim GVS1 As String
Dim GVS1IS As String
Dim Month As String
Set Revenue = ThisWorkbook.Sheets("Revenue") ' use "Set" to assign an object to a variable
With Revenue
GVS1 = .Range("V13").Value ' { always specify the property you want
GVS1IS = .Range("V7").Value ' { here it's the Value
Month = .Range("V4").Value ' "Month" is a string (like "April", not 4)
End With
Set Fnd = ActiveSheet.Range("B5:B25").Find("Generation")
If Fnd Is Nothing Then
MsgBox """Generation"" not found."
Exit Sub
Else
R = Fnd.Row
End If
Set Fnd = ActiveSheet.Range("A1:P15").Find(Month & " Actual")
If Fnd Is Nothing Then
MsgBox """" & Month & " Actual"" not found."
Exit Sub
Else
C = Fnd.Column
End If
Set GVS1Book = Workbooks.Open(GVS1) ' GVS1 must be a path & name
End Sub
When the other workbook is opened I gave up. At that moment Excel will make that workbook the ActiveWorkbook and the sheet which was active when that workbook was saved will become the ActiveSheet. Your code immediately starts deleting columns on that unknown sheet. I couldn't get myself to do that.
As you complete the code I started, just remember that you don't need to activate the other workbook. Excel has done it for you and will give you back your original view when you close that book. Consider using Application.ScreenUpdating = False not to show the active sheet. You don't need to select any worksheet on which you want to delete columns. But you do need to specify the worksheets on which you take action. I have strong doubt that my code looks for the two search criteria on the correct sheet. I specified ActiveSheet because that's what your code implied. So we're probably both wrong :-)

Related

How to find a Excel cell has hyperlink

I have data in Column A in excel..I am iterating through column and i need to find if a cell value has hyperlink init.
LR=Activeworkbook.Worksheets("Emp").Range("A65000").End(xlup).Row
for j=1 to LR
if Thisworkbooks.Worksheets("Emp").cells(j,1)="" then 'Logic to find hyperlink
'Function
end if
next
Identify Cells Containing Hyperlinks
As Red Hare already mentioned in the comments, it is best tested with something like the following:
Dim cell As Range: Set cell = Sheet1.Range("A1")
If cell.Hyperlinks.Count > 0 Then ' has a hyperlink
Else ' has no hyperlink
End If
that is, using the Hyperlinks.Count property of the Hyperlinks object returned by the cell's Hyperlinks property which is a collection of hyperlinks in a range (in this case, a single cell). For a single cell, the Count property will return only 0 or 1 so you could actually use
If cell.Hyperlinks.Count = 1 Then ' has a hyperlink
instead.
Example Code
Option Explicit
Sub IdentifyCellsWithHyperlink()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' If it's not, modify accordingly.
Dim ws As Worksheet: Set ws = wb.Worksheets("Emp")
Dim rg As Range
Set rg = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim cell As Range
For Each cell In rg.Cells
If cell.Hyperlinks.Count > 0 Then ' has a hyperlink
Else ' has no hyperlink
End If
Next cell
End Sub
Here is something that can be used to run through each row to determine if it can be set as a hyperlink. Kinda hard to figure out what the range of possible solutions are that will work for you without fully understanding the context...
Private Sub cmdFollowLink_Click()
CreateHyperlink Me!cmdFollowLink, Me!txtSubAddress, _
Me!txtAddress
End Sub
Sub CreateHyperlink(ctlSelected As Control, _
strSubAddress As String, Optional strAddress As String)
Dim hlk As Hyperlink
Select Case ctlSelected.ControlType
Case acLabel, acImage, acCommandButton
Set hlk = ctlSelected.Hyperlink
With hlk
If Not IsMissing(strAddress) Then
.Address = strAddress
Else
.Address = ""
End If
.SubAddress = strSubAddress
.Follow
.Address = ""
.SubAddress = ""
End With
Case Else
MsgBox "The control '" & ctlSelected.Name _
& "' does not support hyperlinks."
End Select
End Sub

VBA Macro that filters on specific column "U" if column U has data or a date it deletes the entire row

I am new to VBA, Macro. I want the macro to filter on column "U" preferably with column name "Vessel Departed from Port of Loading" if this column has a date or data then delete the entire corresponding row.
My codes below it do not work... Please help I have pasted code and excel screen below for ref
Private Sub CommandButton5_Click()
ActiveWorkbook.Worksheets("POL").Range("U").NumberFormat = "m/d/yyyy"
Rows(2).Select
Rows(1).AutoFilter
'Create a variable that = the last used row in column U
lr = Cells(Rows.Count, "U").End(xlUp).Row
'Create a looping variable # to go backwards from the last used Row# to 1
For i = lr To 1 Step -1
If Cells(i, "U").Value < #1/3/2009# Or Cells(i, "U").Value > #2/3/2010# Then
Rows(i).EntireRow.Delete shift:=xlUp
End If
Next i
End Sub
Like if column U "Vessel Departed from Port of Loading" is having data or date then delete the entire corresponding rows too. Instead of giving a column number "U" column name "Vessel Departed from Port of Loading" would be better because column number may vary... please help
I wrote a macro that will delete anything NOT blank on col "U" (or column21), INCLUDING the entire row, in sheets called "POL"
Based on your description I would do the following:
Option Explicit
Dim wb As Workbook
Dim sRng As Range
Dim fRng As Range
Dim cel As Range
Dim tRow As Long
Dim fCol As Long
Sub foo()
'setting wb as thisworkbook
Set wb = ThisWorkbook
'row 1 assigned into fRng(find range) object
Set fRng = wb.Sheets("POL").Rows(1).Find(what:="Vessel Departed from Port of Loading", LookIn:=xlValues, lookat:=xlWhole)
'gets fRng range object, and assigns its column property value into fCol variable
fCol = fRng.Column
'finding the last row for column 1, make sure you select a col that covers the whole data set, based on last row
tRow = wb.Sheets("POL").Cells(Rows.Count, 1).End(xlUp).Row
'assigning range based on col index based on str search(fCol) + total row count (tRow) in sRng range object
With wb.Sheets("POL")
Set sRng = .Range(.Cells(1, fCol), .Cells(tRow, fCol))
End With
'call sub deltR, the function does a filter based on range, string, and col number passed as argument.
'passing arguments: range (sRng), delete anything not empty, on col#1 (sRng has only one range = columns("U:U" + tRow)
Call deltR(sRng, "<>", 1)
End Sub
Private Sub deltR(ByRef sRng As Range, ByVal aStr As String, ByVal f As Integer)
'this sub procedure looks for a string (aStr) passed in (sRng) range object range, based on col number (f)
With sRng
.AutoFilter field:=f, Criteria1:=aStr
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
wb.Sheets("POL").AutoFilterMode = False
Set sRng = Nothing
End Sub
just run sub procedure "foo()" to run the script.
I named the sheet "POL" based on the code you wrote above. I do not know how your workbook is structured. so I took a guess based on your explanation
Give it a try and get back to me in the comments to fix possible issues.
UPDATE: Please check again, I created an extra range object that searches row 1 for "Vessel Departed from Port of Loading" string, and returns the col index
also I have removed the "set wb = nothing" at the end. I think maybe it was causing the error I read in the comments.
Give it a try one more time and please let me know if you have questions.
Thanks

Concatenating 3 strings the outcome changes randomly

New to VBA coding and 1st time that I'm asking something, so give some slack if you see some dummy code.
I have an Excel Table which in column A has dates in the mm/dd/year format. I want to change it to dd/mm/year and in order to make some practice in VBA, I tried to do it via code (i have tried the Format Cells options but didn't work).
For a start I'm trying to rewrite the Date column in column H with the desired format using the following code:
Public Sub ChangingDateFormat()
Dim dest As Range
Dim dindx As Integer
Dim cll As Range
Dim x As String
Dim y As String
Dim z As String
'Establish where output goes
Set dest = Range("H2")
'Set counter for output rows
dindx = 0
'Establish your North Star reference
Set cll = Range("A2")
'Loop as long as anchor cell down isn't blanc
While cll.Offset(dindx, 0) <> ""
'Test if not empty; if not empty populate destination with data
If cll.Offset(dindx, 0) <> "" Then
x = Left(cll.Offset(dindx, 0), 2)
y = Mid(cll.Offset(dindx, 0), 4, 3)
z = Right(cll.Offset(dindx, 0), 5)
'True case: Output date
dest.Offset(dindx, 0) = y & x & z
'Increment row counter
dindx = dindx + 1
End If
'End While statement
Wend
End Sub
However, when the macro runs, some cells have the desired format and others not.
The Excel sheet looks like this:
My WorkSheet
Any ideas where the problem is? Pointing me to a direction would be deeply appreciated.
Thanks
Try using Format function like that (This is just sample) and try to implement in your code
Sub Test()
Dim r As Range
Set r = Range("A1")
r.Offset(, 3).Value = Format(r.Value, "dd/mm/yyyy")
End Sub
Excel Table (ListObject)
The following covers only the part I have an Excel Table which in column A has dates in the mm/dd/year format. I want to change it to dd/mm/year... i.e. the values in column A are real dates, not text.
Adjust the sheet and table names appropriately.
Since you are dealing with a ListObject (Table), you might consider using its properties.
The following procedures show how you can exploit some of them in two cases.
The first procedure will change the number format in the first column of the table, (not necessarily the first column of the worksheet). It is used when a column is always the first, so the header (title) can be changed.
The second procedure will try to find the given header (Header). If successful, it will apply the number formatting to the column where the header was found. It is used when the header (title) will never change, but the position of the column in the table might.
The Code
Sub IOnlyKnowTheColumnNumber()
' The n-th column of the Table, not the worksheet.
Const DateColumn As Long = 1
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet1")
Dim tbl As ListObject
Set tbl = ws.ListObjects("Table1")
' Define Date Column Range ('rng').
Dim rng As Range
Set rng = tbl.DataBodyRange.Columns(DateColumn)
' Apply formatting to Date Column Range.
rng.NumberFormat = "dd/mm/yyyy" ' "dd\/mm\/yyyy" for international.
' Inform user.
MsgBox "Number format applied.", vbInformation, "Success"
End Sub
Sub IOnlyKnowTheColumnTitle()
Const Header As String = "Date"
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet1")
Dim tbl As ListObject
Set tbl = ws.ListObjects("Table1")
' Define Header Row Range (Headers, Titles).
Dim hRng As Range
Set hRng = tbl.HeaderRowRange
' Try to calculate the Date Column Number.
Dim Temp As Variant
Temp = Application.Match(Header, hRng, 0)
If Not IsError(DateColumn) Then
' Define Date Column.
Dim DateColumn As Long
DateColumn = CLng(Temp)
' Define Date Column Range ('rng').
Dim rng As Range
Set rng = tbl.DataBodyRange.Columns(DateColumn)
' Apply formatting to Data Column Range.
rng.NumberFormat = "dd/mm/yyyy" ' "dd\/mm\/yyyy" for international.
' Inform user.
MsgBox "Number format applied.", vbInformation, "Success"
Else
' inform user.
MsgBox "Could not find '" & Header & "' column.", vbExclamation, "Fail"
End If
End Sub

How do i fix Lmonth loop

I have an Lmonth Loop code that searches though a list of dates to find jobs that were ordered in january (1) for example and copy&pastes those into a new sheet.
The code runs fine but when it gets to then end it flags a #debug error 13'
If i disable the line the code does not function but i cannot work out what is broken.
Sub Search_Month()
Dim datasheet As Worksheet
Set datasheet = Sheet2
Dim Mreport As Worksheet
Set Mreport = Sheet9
Dim Lmonth As Integer
Search = Range("m4").Value
Dim i As Integer
Mreport.Unprotect Password:=rapid1
Mreport.Range("a2:a300").ClearContents
datasheet.Activate
For i = 7 To 5000
Lmonth = Month(Cells(i, 6))
If Lmonth = Search Then
Range(Cells(i, 2), Cells(i + 3, 2)).Copy
Mreport.Activate
Range("A1000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
datasheet.Activate
End If
Next i
Mreport.Activate
Mreport.Protect Password:=rapid1
MsgBox "End of Month Report Updated"
End Sub
The line that flags is Lmonth = Month(Cells(i, 6)) but i dont know why.
All the results the macro finds are correct, just the error at the end is annoying. I think its saying 'the next search line does not show lmonth=1 so i cant run the code anymore so it must be broken"
Debug error 13 is a type mismatch. So the function "Month" is given a value, that cannot be processed.
See Documentation for reference. It needs to be a date.
Your main problem seems the fact, that you just go from line 7 to 5000 without even checking if there is any content. I don't think you can trust the fact, that there are always 4993 entries in the table.
So I recomment to change the loop to something like For i = 7 To ActiveSheet.UsedRange.Rows.Count. Also you can check the datatype before using "Month()" with the "IsDate"-function if you are unsure.
Copy Monthly
I've changed the variable rapid1 to a string. You might want to
change this to make the code work.
Although implementing constants (change only once and change quickly
'in one place' (at the beginning)) and naming them appropriately is
probably increasing readability for others (and for you, after a
while), it might not be so while developing. Therefore I've included
the No Constants Version below the Main Version.
Main Version
Sub Search_Month()
' Data
Const cSearch As String = "M4" ' Search Value Cell Range
Const cFRD As Long = 7 ' First Row Number
Const cOffset As String = 3 ' Copy Row Offset
Const cCol As Variant = "F" ' Search Column Letter/Number
Const cCopy As Variant = "B" ' Copy Column Letter/Number
' Report
Const cFRR As Long = 2 ' First Row Number
Const cWrite As Variant = "A" ' Write Column Letter/Number
' Data
Dim datasheet As Worksheet ' Worksheet
Dim rng As Range ' Last Cell Range
Dim Search As Long ' Search Month
Dim vntMonth As Variant ' Current Month
Dim i As Long ' Row Counter
' Report
Dim Mreport As Worksheet ' Worksheet
Dim FER As Long ' First Empty Row
' Create References to Worksheets
Set datasheet = Sheet2
Set Mreport = Sheet9
' Speed up
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ProcedureExit
' In Data Worksheet
With datasheet
' Assign value from Search Value Cell Range to Search Month.
Search = .Range(cSearch).Value
' In Search Column
With .Columns(cCol)
' Calculate Last Cell Range in Search Column.
Set rng = .Find("*", , xlFormulas, xlWhole, xlByColumns, xlPrevious)
End With
If rng Is Nothing Then ' No data in column (Highly unlikely).
MsgBox "No Data in column '" _
& Split(.Cells(1, cCol).Address, "$")(1) & "'."
GoTo ProcedureExit
End If
' In Report Worksheet
With Mreport
.Unprotect Password:="rapid1"
' Clear contents from First Row to bottom cell of Write Column.
.Cells(cFRR, cWrite).Resize(.Rows.Count - cFRR + 1).ClearContents
' Write First Row Number to First Empty Row.
FER = cFRR
End With
' Loop through cells of Data Worksheet.
For i = cFRD To rng.Row
' Write value of current cell to Current Month.
vntMonth = .Cells(i, cCol)
' Check if Current Month is a date or can be converted to a date.
If IsDate(vntMonth) Then
' Check if month of current cell value is equal to Current Month.
If Month(vntMonth) = Search Then
' Write data from Data Worksheet to Report Worksheet.
Mreport.Cells(FER, cWrite).Resize(cOffset) = _
.Cells(i, cCopy).Resize(cOffset).Value
FER = FER + cOffset
End If
End If
Next
End With
' In Report Worksheet
With Mreport
.Protect Password:="rapid1"
MsgBox "End of Month Report Updated"
End With
ProcedureExit:
' Speed down
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
No Constants Version
Sub Search_Month_No_Constants()
' Data
Dim datasheet As Worksheet ' Worksheet
Dim rng As Range ' Last Cell Range
Dim Search As Long ' Search Month
Dim vntMonth As Variant ' Current Month
Dim i As Long ' Row Counter
' Report
Dim Mreport As Worksheet ' Worksheet
Dim FER As Long ' First Empty Row
' Create References to Worksheets
Set datasheet = Sheet2
Set Mreport = Sheet9
' Speed up
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ProcedureExit
' In Data Worksheet
With datasheet
' Assign value from Search Value Cell Range to Search Month.
Search = .Range("M4").Value
' In Search Column
With .Columns("F")
' Calculate Last Cell Range in Search Column.
Set rng = .Find("*", , xlFormulas, xlWhole, xlByColumns, xlPrevious)
End With
If rng Is Nothing Then ' No data in column (Highly unlikely).
MsgBox "No Data in column 'F'." _
GoTo ProcedureExit
End If
' In Report Worksheet
With Mreport
.Unprotect Password:="rapid1"
' Clear contents from First Row to bottom cell of Write Column.
.Cells(2, "A").Resize(.Rows.Count - 2 + 1).ClearContents
' Write First Row Number to First Empty Row.
FER = 2
End With
' Loop through cells of Data Worksheet.
For i = 7 To rng.Row
' Write value of current cell to Current Month.
vntMonth = .Cells(i, "F")
' Check if Current Month is a date or can be converted to a date.
If IsDate(vntMonth) Then
' Check if month of current cell value is equal to Current Month.
If Month(vntMonth) = Search Then
' Write data from Data Worksheet to Report Worksheet.
Mreport.Cells(FER, "A").Resize(3) = _
.Cells(i, "B").Resize(3).Value
FER = FER + 3
End If
End If
Next
End With
' In Report Worksheet
With Mreport
.Protect Password:="rapid1"
MsgBox "End of Month Report Updated"
End With
ProcedureExit:
' Speed down
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
well this is embarrassing...
I tried many of your options above to no avail, I then went to paste something into my code and it pasted a job number which i thought was odd, but was actually the job no of where the code broke down. So i went to look at this field and found i had entered the date for that field as 07/02/19/, the final forward breaker was throwing a code error.
Deleted the / and re run the code and it worked perfectly with no debug error.
Thanks everyone for your help and advice, I will use your coding and feedback to improve this code and many more in the future
Many thanks again!
rookieerror!

VBA Excel Merging Several Different Structure Sheets Using Common Combined Sheet Headers

I have several sheets with different structure that i need to merge using some of the columns headers that are common
I gathered in the one sheet ("Combine") the common headers and tried to write a macro to find the same column and to its data to the combine sheet, the macro is only getting the first column and not proceeding.
Any guidance with this issue will be appreciated
Dim II%, XX%, ZZ%, I% ' Dim as long
Dim Sht As Worksheet ' Every Sheet on This Workbook
Dim Comb As Worksheet ' Combine Sheet
Set Comb = ThisWorkbook.Worksheets("Combine")
II = 2 ' Start on row 2 - Sheet1 & Sheet2
XX = 2 ' Start on row 2 - Combine sheet
'Looping through the worksheets in the workbook
For Each Sht In ThisWorkbook.Worksheets
' ignore Sheet "Combine" and "Val"
If Sht.Name <> "Combine" And Sht.Name <> "Val" Then
For ZZ = 1 To 100
For I = 1 To 100
If Sheets(Sht.Name).Cells(1, I).Value = Comb.Cells(1, ZZ).Value Then
Do Until IsEmpty(Sht.Columns(1).Cells(II))
Comb.Cells(XX, ZZ).Value = Sheets(Sht.Name).Cells(II, I).Value
II = II + 1
XX = XX + 1
Loop
End If
Next I
I = 1
Next ZZ
End If
II = 2 ' Reset 1st Loop to capture the new sheet data
Next
If I understand your question correctly, you have multiple sheets that have a heading row of some number of columns. You then have data rows below this in corresponding columns.
You’ve looked at the headings in each sheet and added those names that are common to a sheet you’ve called Combine. Not all columns on all sheets are found on the Combine sheet. The Combine sheet is a subset of the total column names in the workbook.
The sheets might contain data from several test runs or whatever. The output might contain common columns as well as some additional data. For example, sheet 1 could contain date, time, location, and result. Sheet 2 could contain date, time, and tester.
You want a combined sheet that shows the common fields, in this case Date, Time, Result, and Tester. You’ve already determined the common headings.
I think your problem might be in Do Until IsEmpty(Sht.Columns(1).Cells(II)). You may be encountering an empty cell.
Also, it is much faster to use Excel's built-in functions to perform moving large blocks of data between sheets.
Given you seem to be learning about VBA and have made a pretty good attempt, I took the liberty to provide you with an example that uses a more advanced way for solving the problem
The code below in effect concatenates the data from each sheet and common column on to the Combine sheet. It leaves blanks where a column does not have a data sheet have data that would be copied into the Combine column. This means that there will be blank cells under the columns Result and Test – based on the source data sheet.
I hope you find this helpful and that it answers your question. I have learned a lot from other's example on this site and am trying to pay it forward.
Option Explicit
Public Sub Tester()
'Not needed
'Dim II%, XX%, ZZ%, I% ' Dim as long
Dim Comb As Worksheet ' Combine Sheet
Set Comb = ThisWorkbook.Worksheets("Combine")
'Declare a range object and assign it to contain column names
'from Combine. This range, converted to a list
'below will compare the combined heading names with
'each column heading on each sheet.
Dim rngCombineHeadings As Range
'set combine headings into the range using the function
'EndOfRangeColumn, which is decribed below
Set rngCombineHeadings = EndOfRangeColumn(Comb.Range("A1"))
'Declare a collection to be used in the for loop to compare
'Combine column headings with each source sheets headings
'Only copy those columns that match
Dim colCombinedHeadings As Collection
'Get a collection (aka list of strings) of the column headings
Set colCombinedHeadings = GetCommonHeadings(rngCombineHeadings)
'Declare two ranges to be used as the index inside
'for loops below.
Dim combineColTargetRng As Range
Dim colRng As Range
'Declare a variant to used use the index for looing
'through the Combine sheet headings
Dim vHeading As Variant
'Declare tblRng. It will be set to contain the entire data table
'on each sheet. Row 1 contains the headings, rows 2 - n contain
'the data that may be moved.
Dim tblRng As Range
'This is the range that will be manipulated and copied
'to the Combine sheet
Dim copyRng As Range
'Looping through the worksheets in the workbook
'Index variable used in for each loop below best practice is
'declare you variables near where they are used.
Dim Sht As Worksheet ' Every Sheet on This Workbook
For Each Sht In ThisWorkbook.Worksheets
' ignore Sheet "Combine" and "Val"
If Sht.Name <> "Combine" And Sht.Name <> "Val" Then
'Set the data table to the tblRng object.
Set tblRng = EndOfRangeRow(Sht.Range("A1"))
Set tblRng = EndOfRangeColumn(tblRng)
'For each sheet, loop through each headings on
'the Combined sheet and compare those to the
'headings on the data table on the current sheet
For Each vHeading In colCombinedHeadings
For Each colRng In tblRng.Columns
'if the heading on Combined = the current
'columns heading then, copy the data
'to the combined sheet.
If vHeading = colRng.Value2(1, 1) Then
'Resize the copy range to exclude the heading row
'and to reduce the size by one row, reflecting removal
'of the header row from the range
Set copyRng = ResizeTheRange(colRng.Offset(1, 0))
'Find the column on the Combine sheet that
'matches the current value in vHeading
Set combineColTargetRng = rngCombineHeadings.Find(colRng.Value2(1, 1))
'Copy the current sheet-current column to the clipboard
copyRng.Copy
'The if statement below determines if this is the first
'column of data being copied to the Combine sheet
'if it is, the row 2 current column is empty
'otherwise it has a value and we need to move the paste point
'to the end of the current Combine sheet column
If combineColTargetRng.Offset(1, 0).Value2 = "" Then
Set combineColTargetRng = combineColTargetRng.Offset(1, 0)
Else
Set combineColTargetRng = EndOfRangeRow(combineColTargetRng)
Set combineColTargetRng = _
combineColTargetRng.Offset( _
combineColTargetRng.Rows.Count, 0)
End If
'Paste the values copied from the current sheet
'that are under the same column heading as on the combined sheet
'There are a number of options for pasteSpecial
'See https://learn.microsoft.com/en-us/office/vba/api/excel.range.pastespecial
combineColTargetRng.PasteSpecial Paste:=xlPasteAll
End If
Next
Next
End If
Next
End Sub
'*****************************************************************************
'**
'** This function demonstrates use of the ParamArray. It enables the
'** calling routine, to provide the range as an Excel Range, a Collection
'** an Array, or a list of strings.
'**
'** Calling the Function:
'** Dim aCol as Collection
'** Set aCol = GetCommonHeadings(aCol)
'** Dim rngExcelRange as Range
'** set rngExcelRange = Range("A1:X1")
'** Set aCol = GetCommonHeadings(rngExcelRange)
'** Dim vArr() as Variant
'** vArr = Array("H1", "H2", "H3", "H4")
'** Set aCol = GetCommonHeadings(vArr)
'** Set aCol = GetCommonHeadings("Title1", "Title2", "Title3", "Title4")
Public Function GetCommonHeadings(ParamArray mRange() As Variant) As Collection
'Instantiate the return collection
Dim retVal As New Collection
Dim nDx As Long
If UBound(mRange) < 0 Then
'Cannot do anything without the heading range
Set retVal = Nothing
ElseIf TypeOf mRange(0) Is Range Then
'Heading Range is an Excel Range
Dim rngMaster As Range
Dim colRng As Range
Set rngMaster = mRange(0)
For Each colRng In rngMaster.Columns
retVal.Add colRng.Value2
Next
ElseIf TypeOf mRange(0) Is Collection Then
'Heading Range is a collection of text strings
Set retVal = mRange(0)
ElseIf VarType(mRange(0)) = vbArray + vbVariant Then
'Heading Range passed is an array of strings
Dim varArr() As Variant
varArr = mRange(0)
For nDx = 0 To UBound(varArr)
retVal.Add varArr(nDx)
Next
ElseIf VarType(mRange(0)) = vbString Then
'mRange contains an array of strings
For nDx = 0 To UBound(mRange)
retVal.Add mRange(nDx)
Next
Else
Set retVal = Nothing
End If
Set GetCommonHeadings = retVal
End Function
'****************************************************************************
'**
'** The Functions EndOfRangeColumn, EndOfRangeRow, StartOfRangeColumn, and
'** StartOfRangeRow take one parameter which is an Excel Range. Based on
'** the funtions name it will return the cell that is at the other end.
'** These are just wrappers to make the code more readable. The real work
'** is done by the Private Function GetRangeAtEnd. The private function
'** takes an Excel Range and the direction you want to move.
Public Function EndOfRangeColumn(ByRef mStartOfRange As Range) As Range
Set EndOfRangeColumn = GetRangeAtEnd(mStartOfRange, xlToRight)
End Function
Public Function EndOfRangeRow(ByRef mStartOfRange As Range) As Range
Set EndOfRangeRow = GetRangeAtEnd(mStartOfRange, xlDown)
End Function
Public Function StartOfRangeColumn(ByRef mEndOfRange As Range) As Range
Set StartOfRangeColumn = GetRangeAtEnd(mStartOfRange, xlToLeft)
End Function
Public Function StartOfRangeRow(ByRef mEndOfRange As Range) As Range
Set StartOfRangeRow = GetRangeAtEnd(mStartOfRange, xlUp)
End Function
Private Function GetRangeAtEnd(ByRef mRange As Range, ByVal mDirection As XlDirection) As Range
Set GetRangeAtEnd = Range(mRange, mRange.End(mDirection))
End Function
'***************************************************************
'**
'** The Private Function ResizeTheRange takes an Excel range
'** provide in the parameter. In effect it removes the first
'** row from the provided range, and reduces the size by one.
Private Function ResizeTheRange(ByRef mRange As Range) As Range
Dim retVal As Range
Set retVal = mRange.Offset(1, 0)
Set retVal = retVal.Resize(retVal.Rows.Count - 1, 1)
Set retVal = EndOfRangeRow(retVal)
Set ResizeTheRange = retVal
End Function

Resources