This code searches data on Sheet2 and if it finds it on Sheet2,
it copies full row on Sheet1.
I would like to edit it:
so when I search for example "John%Wayne"
it looks for cells that contain and John and Wayne in its string.
Sub myFind()
'Standard module code, like: Module1.
'Find my data and list found rows in report!
Dim rngData As Object
Dim strDataShtNm$, strReportShtNm$, strMySearch$, strMyCell$
Dim lngLstDatCol&, lngLstDatRow&, lngReportLstRow&, lngMyFoundCnt&
On Error GoTo myEnd
'*******************************************************************************
strDataShtNm = "Sheet2" 'This is the name of the sheet that has the data!
strReportShtNm = "Sheet1" 'This is the name of the report to sheet!
'*******************************************************************************
Sheets(strReportShtNm).Select
Application.ScreenUpdating = False
'Define data sheet's data range!
Sheets(strDataShtNm).Select
With ActiveSheet.UsedRange
lngLstDatRow = .Rows.Count + .Row - 1
lngLstDatCol = .Columns.Count + .Column - 1
End With
Set rngData = ActiveSheet.Range(Cells(1, 1), Cells(lngLstDatRow, lngLstDatCol))
'Get the string to search for!
strMySearch = InputBox("Enter what to search for, below:" & vbLf & vbLf & _
"Note: The search is case sensitive!", _
Space(3) & "Find All", _
"")
'Do the search!
For Each Cell In rngData
strMyCell = Cell.Value
'If found then list entire row!
If strMyCell = strMySearch Then
lngMyFoundCnt = lngMyFoundCnt + 1
ActiveSheet.Rows(Cell.Row & ":" & Cell.Row).Copy
With Sheets(strReportShtNm)
'Paste found data's row!
lngReportLstRow = .UsedRange.Rows.Count + .UsedRange.Row
ActiveSheet.Paste Destination:=.Range("A" & lngReportLstRow).EntireRow
End With
End If
Next Cell
myEnd:
'Do clean-up!
Application.ScreenUpdating = True
Application.CutCopyMode = False
Sheets(strReportShtNm).Select
'If not found then notify!
If lngMyFoundCnt = 0 Then
MsgBox """" & strMySearch & """" & Space(3) & "Was not found!", _
vbCritical + vbOKOnly, _
Space(3) & "Not Found!"
End If
End Sub
You can use Find with the * wildcard (or if you really want to use % then replace % with * in the code):
Sub myFind()
Dim rToSearch As Range
Dim sMySearch As String
Dim rFound As Range
Dim sFirstAddress As String
Dim lLastRow As Long
'Get the string to search for!
sMySearch = InputBox("Enter what to search for, below:" & vbLf & vbLf & _
"Note: The search is case sensitive!", _
Space(3) & "Find All", _
"")
With ThisWorkbook
'Set reference to data in column A.
With .Worksheets("Sheet2")
Set rToSearch = .Range(.Cells(1, 1), .Columns(1).Find("*", , , , xlByColumns, xlPrevious))
End With
'Find the last row containing data in Sheet 1.
With .Worksheets("Sheet1")
On Error Resume Next
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row + 1
On Error GoTo 0
If lLastRow = 0 Then lLastRow = 1
End With
End With
'Use find to search your text.
'FindNext will, strangely enough, find the next occurrence and keep looping until it
'reaches the top again - and back to the first found address.
With rToSearch
Set rFound = .Find(What:=sMySearch, LookIn:=xlValues)
If Not rFound Is Nothing Then
sFirstAddress = rFound.Address
Do
rFound.EntireRow.Copy Destination:=ThisWorkbook.Worksheets("Sheet1").Cells(lLastRow, 1)
lLastRow = lLastRow + 1
Set rFound = .FindNext(rFound)
Loop While rFound.Address <> sFirstAddress
End If
End With
End Sub
Related
This is my desired flow:
On "Sheet2" you can select a macro "Search by first name"
You see a popup to enter a name, you enter a name (X) and select ok
It will search the next sheet, "Master", and look for results where first name = X
and finally return these results back on "Sheet2"
Here's a screenshot of the two sheets:
Sheet 2
and
Master
The following VB code means that it only returns 1 result when there should be multiple sometimes:
Sub Searchbyfirstname()
Dim wks As Excel.Worksheet
Dim rCell As Excel.Range
Dim fFirst As String
Dim i As Long
Dim MyVal As String
MyVal = InputBox("Enter the first name of the employees record you need", "Search By First Name", "")
If MyVal = "" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Cells(5, 1)
.Value = "The below data has been found for " & MyVal & ":"
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
i = 2
For Each wks In ActiveWorkbook.Worksheets
If wks.Name <> "List" Then
With wks.Range("B:B")
Set rCell = .Find(MyVal, , , xlWhole, xlByColumns, xlNext, False)
If Not rCell Is Nothing Then
fFirst = rCell.Address
Do
rCell.Hyperlinks.Add Cells(6, 1), "", "'" & wks.Name & "'!" & rCell.Address
wks.Range("A" & rCell.Row & ":Z" & rCell.Row).Copy Destination:=Cells(6, 1)
Set rCell = .FindNext(rCell)
i = i + 3
Loop While Not rCell Is Nothing And rCell.Address <> fFirst
End If
End With
End If
Next wks
Set rCell = Nothing
If i = 2 Then
MsgBox "No record for " & MyVal & " has been found", 64, "No Matches"
Cells(1, 1).Value = ""
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Any help would be very much appreciated, thanks!
Ok so I am pretty sure I have the answer now that Maertin and chris neilsen pointed out the errors with hardcoding.
I have posted my code again but the points where I have added or changed are not code (didn't know the best way to format this):
Sub Searchbyfirstname()
Dim wks As Excel.Worksheet
Dim rCell As Excel.Range
Dim fFirst As String
Dim i As Long
Dim MyVal As String
MyVal = InputBox("Enter the first name of the employees record you need", "Search By First Name", "")
If MyVal = "" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Cells(5, 1)
.Value = "The below data has been found for " & MyVal & ":"
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
i = 2
For Each wks In ActiveWorkbook.Worksheets
If wks.Name <> "List" Then
With wks.Range("B:B")
Set rCell = .Find(MyVal, , , xlWhole, xlByColumns, xlNext, False)
If Not rCell Is Nothing Then
fFirst = rCell.Address
Dim x As Integer
x = 6
With Sheets("Sheet2")
.Rows(6 & ":" & .Rows.Count).Delete
End With
' for this part I have created the variable x, then I'm assigning this 6 because that's the first row I want to put the data in, then I am saying if there's anything in row 6 or below, delete it
Do
rCell.Hyperlinks.Add Cells(x, 1), "", "'" & wks.Name & "'!" & rCell.Address
'see this and row below, instead of being Cells(6, 1), it is now x and this means it will paste to 6, then if there's another 7 and so on
wks.Range("A" & rCell.Row & ":Z" & rCell.Row).Copy Destination:=Cells(x, 1)
Set rCell = .FindNext(rCell)
i = i + 3
x = x + 1
' Here I am incrementing x by 1 so that if there's another piece of data to paste it will paste in the next row - on first go this would be row 7
Loop While Not rCell Is Nothing And rCell.Address <> fFirst
End If
End With
End If
Next wks
Set rCell = Nothing
If i = 2 Then
MsgBox "No record for " & MyVal & " has been found", 64, "No Matches"
Cells(1, 1).Value = ""
With Sheets("Sheet2")
.Rows(5 & ":" & .Rows.Count).Delete
End With
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I have a spreadsheet with two columns (A and B). I would like to (FOR) loop through column B until two or more of the cell values match. For the cells that match in column B, I would like to loop through their corresponding values in column A. If their corresponding values are not identical, I want all of the rows involved to be highlighted.
I know it's not right/complete, but below is the basic structure I would like to follow. Any and all help is greatly appreciated. Thank you.
Sub MySUb()
Dim iRow As Integer
For iRow = 2 To ActiveSheet.UsedRange.Rows.Count
If Trim(range("A" & iRow)) <> "" And Trim(range("B" & iRow)) = Trim(range("B" & iRow)) Then
range("A" & iRow, "B" & iRow).Interior.ColorIndex = 6
End If
Next
End Sub
You can first sort based on Column B, then modify your code to:
Sub MySUb()
Dim iRow As Integer
For iRow = 1 To ActiveSheet.UsedRange.Rows.Count
If Trim(Range("A" & iRow).Text) <> "" And _
Trim(Range("B" & iRow).Text) = Trim(Range("B" & iRow + 1).Text) And _
Trim(Range("A" & iRow).Text) <> Trim(Range("A" & iRow + 1).Text) Then
Range("A" & iRow, "B" & iRow).Interior.ColorIndex = 6
Range("A" & iRow + 1, "B" & iRow + 1).Interior.ColorIndex = 6
End If
Next
End Sub
EDIT:
Here is a better solution which can handle the case where in column B there >2 matching cells, but the corresponding cells in A do not match (i.e. at least one of them is different). In this case all of those cells are marked.
Sub MySUb()
Dim iRow As Integer
Dim jRow As Integer
Dim kRow As Integer
For iRow = 1 To ActiveSheet.UsedRange.Rows.Count
'If Trim(Range("A" & iRow).Text) <> "" Then
For jRow = iRow To ActiveSheet.UsedRange.Rows.Count 'Finds the last non-matching item in B
If Trim(Range("B" & jRow).Text) <> Trim(Range("B" & iRow).Text) Then
Exit For
End If
Next jRow
For kRow = iRow To jRow - 1
If Trim(Range("A" & iRow).Text) <> Trim(Range("A" & kRow).Text) Then
Range("A" & iRow, "B" & kRow).Interior.ColorIndex = jRow + 1 'Or can be 6
End If
Next kRow
Next iRow
End Sub
How about something like this, using a dictionary to track the instances of an item in Column B and then testing the Column A values for each unique instance of Column B values. If one fails to match then all instances are marked.
Sub DuplicateChecker()
Dim rngColumnB As Range
Set rngColumnB = Range("B2", Range("B2").End(xlDown))
Dim rngCell As Range
Dim rngDupe As Range
Dim rngDuplicateB As Range
Dim dctValuesChecked As Dictionary
'requires enabled reference library for 'Microsoft Scripting Runtime'
Set dctValuesChecked = New Dictionary
Dim strColumnAValue As String
For Each rngCell In rngColumnB
strColumnAValue = rngCell.Offset(0, -1).Value
If Not dctValuesChecked.Exists(Trim(rngCell.Value)) Then
Call dctValuesChecked.Add(rngCell.Value, rngCell.Row)
Else
Set rngDuplicateB = FindItemsInRange(rngCell.Value, rngColumnB)
rngDuplicateB.EntireRow.Select
For Each rngDupe In rngDuplicateB
If Not rngDupe.Offset(0, -1).Value = strColumnAValue Then
rngDuplicateB.Interior.ColorIndex = 6
rngDuplicateB.Offset(0, -1).Interior.ColorIndex = 6
End If
Next rngDupe
End If
Next rngCell
End Sub
Function FindItemsInRange(varItemToFind As Variant, _
rngSearchIn As Range, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlPart, _
Optional blnMatchCase As Boolean = False) As Range
'adapted from a function by Aaron Blood found on the Ozgrid forums:
'http://www.ozgrid.com/forum/showthread.php?t=27240
With rngSearchIn
Dim rngFoundItems As Range
Set rngFoundItems = .Find(What:=varItemToFind, _
LookIn:=LookIn, _
LookAt:=LookAt, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=blnMatchCase, _
SearchFormat:=False)
If Not rngFoundItems Is Nothing Then
Set FindItemsInRange = rngFoundItems
Dim strAddressOfFirstFoundItem As String
strAddressOfFirstFoundItem = rngFoundItems.Address
Do
Set FindItemsInRange = Union(FindItemsInRange, rngFoundItems)
Set rngFoundItems = .FindNext(rngFoundItems)
Loop While Not rngFoundItems Is Nothing And _
rngFoundItems.Address <> strAddressOfFirstFoundItem
End If
End With
End Function
I wrote an Excel macro and it seems to work fine. It displays an inputbox and once I give the value in it. It saves that value into first cell of column C (C1). However the second time I run macro I want it to be written into C2 and keep all datas in different rows in column C but each time, it writes it into C1 and cause a data loss.
Sub DataInput()
Dim SearchTarget As String
Dim myRow As Long
Dim Rng As Range
Static PrevCell As Range
Dim FoundCell As Range
Dim CurCell As Range
Dim a As String
Dim Target As Range
'SearchTarget = "asdf"
SearchTarget = InputBox("Scan or type product barcode...", "New State Entry")
If PrevCell Is Nothing Then
myRow = Selection.Row
Set PrevCell = Range("C" & myRow)
End If
'Set Rng = Range("C:C,E:E") 'Columns for search defined here
Set Rng = Range("C:C,C:C") 'Columns for search defined here
With Rng
Set FoundCell = .Cells.Find(What:=SearchTarget, _
After:=PrevCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True)
End With
If FoundCell Is Nothing Then
MsgBox SearchTarget & " was not found."
Range("C1").Value = InputBox("code?")
Range("D1").Value = Now()
Else
FoundCell.Activate
' If PrevCell.Address = FoundCell.Address Then
' MsgBox "there's only one!"
' End If
ActiveCell.Offset(0, 1).Select
timestamp = Format(Now(), "dd-mmm-yy hh:mm")
ActiveCell = timestamp
ActiveCell = Now()
ActiveCell.Offset(0, 2).Select
ActiveCell = "T141000"
ActiveCell.Offset(0, 1).Select
Set PrevCell = FoundCell
End If
End Sub
The problem here lies in your if statement - you are always storing the newly entered codes in cells C1 and the date in D1. You need to dynamically work out the next available row number and use that instead. Try something like this:
Public Sub DataInput()
...
If FoundCell Is Nothing Then
MsgBox SearchTarget & " was not found."
Dim nextFreeRow As Integer
nextFreeRow = Range("C" & Rows.Count).End(xlUp).Row + 1
Range("C" & nextFreeRow).Value = InputBox("code?")
Range("D" & nextFreeRow).Value = Now()
Else
...
End If
...
End Sub
Hi all I need to selectively copy entire rows from sheet1 to other sheet. As of now I am using checkboxes to select the rows and then copy the selected rows to sheet of user's choice. But I am facing a bizarre error. For sometime the code runs fine, copying exact data to sheets but after some time it copies erroneous values from nowhere. Can you please help me with this? Pasting the code I am using.
Sub Addcheckboxes()
Dim cell, LRow As Single
Dim chkbx As CheckBox
Dim MyLeft, MyTop, MyHeight, MyWidth As Double
Application.ScreenUpdating = False
LRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For cell = 2 To LRow
If Cells(cell, "A").Value <> "" Then
MyLeft = Cells(cell, "E").Left
MyTop = Cells(cell, "E").Top
MyHeight = Cells(cell, "E").Height
MyWidth = Cells(cell, "E").Width
ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
With Selection
.Caption = ""
.Value = xlOff
.Display3DShading = False
End With
End If
Next cell
Application.ScreenUpdating = True
End Sub
Sub RemoveCheckboxes()
Dim chkbx As CheckBox
For Each chkbx In ActiveSheet.CheckBoxes
chkbx.Delete
Next
End Sub
Sub CopyRows()
Dim Val As String
Val = InputBox(Prompt:="Sheet name please.", _
Title:="ENTER SHEET NAME", Default:="Sheet Name here")
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = 1 Then
For r = 1 To Rows.Count
If Cells(r, 1).Top = chkbx.Top Then
With Worksheets(Val)
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & LRow & ":AF" & LRow) = _
Worksheets("Usable_Inv_Data").Range("A" & r & ":AF" & r).Value
End With
Exit For
End If
Next r
End If
Next
End Sub
Normal Copy Output:
Erroneous Copy Output for same values:
Doing a quick comparison of the normal and the erroneous outputs, it looks like some of your cells/columns are not formatted correctly in your destination sheet (where you are "pasting" the values).
For example, your Base Change column in the Normal copy (the value 582.16) is formatted as a General or Number. The same column in the destination sheet is formatted as a date (582.16 converted to a date value in Excel will be 8/4/1901, or 8/4/01, as shown in your screen.
Just make sure the columns are formatted to display the data type you expect. On your destination sheet, select the column, right-click "Format Cells", and then select the appropriate data type.
---EDIT---
To automate the formatting, you would have to copy and paste the values, inclusive of the formats. Your code would change from this:
With Worksheets(Val)
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & LRow & ":AF" & LRow) = _
Worksheets("Usable_Inv_Data").Range("A" & r & ":AF" & r).Value
End With
TO
With Worksheets(Val)
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
Worksheets("Usable_Inv_Data").Range("A" & r & ":AF" & r).Copy
.Range("A" & LRow).PasteSpecial (xlPasteValuesAndNumberFormats)
End With
I have added the checkbox with LinkedCell property. This helps to identify the rows when checkbox is checked.
Also i have added a function check_worksheet_exists which will check if the workbook exist.
Sub Addcheckboxes()
Dim cell, LRow As Single
Dim chkbx As CheckBox
Dim MyLeft, MyTop, MyHeight, MyWidth As Double
Application.ScreenUpdating = False
LRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).row
For cell = 2 To LRow
If Cells(cell, "A").Value <> "" Then
MyLeft = Cells(cell, "E").Left
MyTop = Cells(cell, "E").Top
MyHeight = Cells(cell, "E").Height
MyWidth = Cells(cell, "E").Width
ActiveSheet.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
With Selection
.Caption = ""
.Value = xlOff
.Display3DShading = False
.LinkedCell = Cells(cell, "AZ").Address
End With
End If
Next cell
Application.ScreenUpdating = True
End Sub
Sub RemoveCheckboxes()
Dim chkbx As CheckBox
For Each chkbx In ActiveSheet.CheckBoxes
chkbx.Delete
Next
End Sub
Sub CopyRows()
Dim Val As String
Dim row As Long
Val = InputBox(Prompt:="Sheet name please.", Title:="ENTER SHEET NAME", Default:="Sheet Name here")
If check_worksheet_exists(ThisWorkbook, Val, False) = False Then
Exit Sub
End If
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = 1 Then
row = Range(chkbx.LinkedCell).row
With Worksheets(Val)
LRow = .Range("A" & Rows.Count).End(xlUp).row + 1
.Range("A" & LRow & ":AF" & LRow) = ActiveSheet.Range("A" & row & ":AF" & row).Value
End With
End If
Next
End Sub
Function check_worksheet_exists(tBook As Workbook, ByVal check_sheet As String, Optional no_warning As Boolean = False) As Boolean
On Error Resume Next
Dim wkSht As Worksheet
Set wkSht = tBook.Sheets(check_sheet)
If Not wkSht Is Nothing Then
check_worksheet_exists = True
ElseIf wkSht Is Nothing And no_warning = False Then
MsgBox "'" & check_sheet & "' sheet does not exist", vbCritical, "Error"
End If
On Error GoTo 0
End Function
i cannot immediately see the errors you refer to, unless you are referring to the sequences of hash-signs ###? These just indicate that the columns aren't wide enough.
Worksheets(Val).Range("A1").CurrentRegion.EntireColumn.AutoFit
BTW I don't think Val is a sensible variable name ;)
Need some help with the following:
I have several worksheets with the same structure and within each worksheet I have two columns (let's call them X & Y) that I need to copy with their cellvalues (letter-number combination) and also copy the values of Column A-F to an own sheet for X and Y.
On the "new" sheet I want to put X/Y to column A sort the values after A and attach a constant hyperlink to each cellvalue in A.
So X or Y goes to A and A-F to B-G.
Then I want to make column F or the new G clickable so that it will take me to the row in the according worksheet.
X and Y don't always happen to be in column X or Y but I think this can be solved with a "name search".
When I execute my code then for example worksheet3 will overwrite the values of worksheet1 and my hyperlink structure is wrong too. The sorting is left out since that is working.
Function CopyAndSort(ByRef mySheet As Worksheet)
' If mySheet.Name <> "Sheet1" Then
' Exit Function
' End If
mySheet.Activate
Set sheetCS = Sheets("CopyAndSort Sheet")
sheetCS.Range("A:A").Value = ""
lastRowCS = Range("X:X").Cells.Find("*", , , , , xlPrevious).Row
rowNumber = 1
For rowCopy = 5 To lastRowFO
sheetCopy = Range("BE" & rowCopy)
If Trim(sheetCopy) <> "" Then
sheetCopy = Replace(sheetCopy, """", "")
If InStr(1, sheetCopy, ",", vbTextCompare) <> 0 Then
sheetCopyArray = Split(sheetCopy, ",")
Else
sheetCopyArray = Array(sheetCopy)
End If
For Each copy In sheetCopyArray
rowNumber = rowNumber + 1
copy_Value = copy
' test for url
' sheetCS.Cells(rowNumber, 1).Formula = "=HYPERLINK(""ConstURL & copyValue"")"
sheetCS.Cells(rowNumber, 1) = copy_Value
copy_Value = Cells(rowCopy, 1)
sheetCS.Cells(rowNumber, 2) = copy_Value
copy_Value = Cells(rowCopy, 2)
sheetCS.Cells(rowNumber, 3) = copy_Value
copy_Value = Cells(rowCopy, 3)
sheetCS.Cells(rowNumber, 4) = copy_Value
copy_Value = Cells(rowCopy, 4)
sheetCS.Cells(rowNumber, 5) = copy_Value
copy_Value = Cells(rowCopy, 5)
sheetCS.Cells(rowNumber, 6) = copy_Value
Next
End If
Next
So how can I manage to not overwrite the values and attach the correct hyperlink syntax, plus making colum G clickable?
And can I use one function for X and Y?
Some code examples would help me alot.
Thank you.
UPDATE:
i forgot to mention that X & Y will always be next to each other.
Example:
Sheet1:
|ColA|ColB|ColC|ColD|ColF|....|ColX|ColY|
Sheet2: here "ColX" is in ColQ and ColY in ColR
|ColA|ColB|ColC|ColD|ColF|....|ColXinColQ|ColYinColR|
CopySheet_of_X: now copy ColX plus ColA-ColF of Sheet1 and do the same for Sheet2 where X is in ColQ
Output for both sheets:
|ColX|ColA|ColB|ColC|ColD|ColF|
CopySheet_of_Y: now copy ColY plus ColA-ColF of Sheet1 and do the same for Sheet2 where Y is in ColR
Output for both sheets:
|ColY|ColA|ColB|ColC|ColD|ColF|
Hyperlink:
so now the values of ColX and ColY should be concatenated with a preceding hyperlink:
If a cell in ColX has the value of "someValue1" then it should be turned into myurl://sometext=someValue1
and I don't know the right way to jump back to the row when clicking on ColF.
Try this. Paste this in a module and run Sub Sample.
Option Explicit
Const hLink As String = "d3://d3explorer/idlist="
Sub Sample()
Dim sheetsToProcess
Set sheetsToProcess = Sheets(Array("Sheet1", "Sheet2"))
CopyData sheetsToProcess, "CopySheet_of_X", "FirstLinkValue"
'~~> Similarly for Y
'CopyData sheetsToProcess, "CopySheet_of_Y", "SecondLinkValue"
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' USAGE '
' wsI : Worksheet Collection '
' wsONm : name of the new sheet for output '
' XY : Name of the X or Y Header '
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Sub CopyData(wsI, wsONm As String, XY As String)
Dim ws As Worksheet, sSheet As Worksheet
Dim aCell As Range
Dim lRow As Long, LastRow As Long, lCol As Long, i As Long, j As Long
Dim MyAr() As String
'~~> Delete the Output sheet if it is already there
On Error Resume Next
Application.DisplayAlerts = False
Sheets(wsONm).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'~~> Recreate the output sheet
Set ws = Sheets.Add: ws.Name = wsONm
'~~> Create Headers in Output Sheet
ws.Range("A1") = XY
wsI(1).Range("A3:F3").Copy ws.Range("B1")
'~~> Loop throught the sheets array
For Each sSheet In wsI
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row + 1
With Sheets(sSheet.Name)
'~~> Find the column which has X/Y header
Set aCell = .Rows(3).Find(What:=XY, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If aCell Is Nothing Then
'~~> If not found, inform and exit
MsgBox XY & " was not found in " & .Name, vbCritical, "Exiting Application"
Exit Sub
Else
'~~> if found then get the column number
lCol = aCell.Column
'~~> Identify the last row of the sheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the X Column and split values
For i = 4 To lRow
If InStr(1, .Cells(i, lCol), ",") Then '<~~ If values like A1,A2,A3
MyAr = Split(.Cells(i, lCol), ",")
For j = 0 To UBound(MyAr)
'~~> Add hyperlink in Col 1
With ws
.Cells(LastRow, 1).Value = MyAr(j)
.Hyperlinks.Add Anchor:=.Cells(LastRow, 1), Address:= _
hLink & .Cells(LastRow, 1).Value, TextToDisplay:=.Cells(LastRow, 1).Value
End With
.Range("A" & i & ":F" & i).Copy ws.Range("B" & LastRow)
'~~> Add hyperlink in Col 2
With ws
.Hyperlinks.Add Anchor:=.Cells(LastRow, 7), Address:="", SubAddress:= _
sSheet.Name & "!" & "A" & i, TextToDisplay:=.Cells(LastRow, 7).Value
End With
LastRow = LastRow + 1
Next j
Else '<~~ If values like A1
'~~> Add hyperlink in Col 1
With ws
.Cells(LastRow, 1).Value = Sheets(sSheet.Name).Cells(i, lCol)
.Hyperlinks.Add Anchor:=.Cells(LastRow, 1), Address:= _
hLink & .Cells(LastRow, 1).Value, TextToDisplay:=.Cells(LastRow, 1).Value
End With
.Range("A" & i & ":F" & i).Copy ws.Range("B" & LastRow)
'~~> Add hyperlink in Col 2
With ws
.Hyperlinks.Add Anchor:=.Cells(LastRow, 7), Address:="", SubAddress:= _
sSheet.Name & "!" & "A" & i, TextToDisplay:=.Cells(LastRow, 7).Value
End With
LastRow = LastRow + 1
End If
Next i
End If
End With
Next
'~~> Sort the data
ws.Columns("A:G").Sort Key1:=ws.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End Sub