I got the following code, which is supposed to
1) Search for my word, copy and paste the entire row that contains the word into new sheet
2) Search for a word after the 1st, then copy and paste that entire row beside the contents of 1) in the new sheet.
Could someone take a look, I am having trouble actually getting the results, there is no error I am getting. So I assume it is the whole copy and paste to my new sheet name. However i am not 100% sure.
Sub stack()
Dim OSheet As String
Dim NSheet As String
Dim i As Integer
Dim LRow As Integer
Dim NSLRow As Integer
OSheet = "Sheet1" 'Old Sheet Name
NSheet = "Sheet7" 'New Sheet Name
LRow = Sheets(OSheet).Cells(Rows.Count, 1).End(xlUp).Row 'Last Row in Old Sheet
Sheets(OSheet).Activate
For i = 2 To LRow
'Finds last row in the New Sheet
If Sheets(NSheet).Cells(2, 1) = "" Then
NSLRow = 1
Else
NSLRow = Sheets(NSheet).Cells(Rows.Count, 1).End(xlUp).Row
End If
'If cell has "First Name then..."
Dim StrX As String
If InStr(LCase(Cells(i, 1)), LCase("stack:")) Then
StrX = Range(Cells(NSLRow + 1, 1), Cells(NSLRow + 1, 6)).Address
Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
ElseIf InStr(LCase(Cells(i, 1)), LCase("overflow:")) Then
StrX = Range(Cells(NSLRow + 1, 7), Cells(NSLRow + 1, 8)).Address
Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
End If
Next i
End Sub
EDIT, Expected result:
!http://i.imgur.com/69elWuB.jpg
EDIT, updated code with some fixes you guys mentioned.
Sub stackv2()
'added Sheets(OSheets)to Range Cells
Dim OSheet As String
Dim NSheet As String
Dim i As Integer
Dim LRow As Integer
Dim NSLRow As Integer
OSheet = "Sheet1" 'Old Sheet Name
NSheet = "Sheet7" 'New Sheet Name
LRow = Sheets(OSheet).Cells(Rows.Count, 1).End(xlUp).Row 'Last Row in Old Sheet
Sheets(OSheet).Activate
For i = 2 To LRow
'Finds last row in the New Sheet
If Sheets(NSheet).Cells(2, 1) = "" Then
NSLRow = 1
Else
NSLRow = Sheets(NSheet).Cells(Rows.Count, 1).End(xlUp).Row
End If
'If cell has "First Name then..."
Dim StrX As String
If InStr(LCase(Cells(i, 1)), LCase("first name")) Then
StrX = Sheets(OSheet).Range(Sheets(OSheet).Cells(NSLRow + 1, 1), Sheets(OSheet).Cells(NSLRow + 1, 6)).Address
Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
ElseIf InStr(LCase(Cells(i, 1)), LCase("last name")) Then
StrX = Sheets(OSheet).Range(Sheets(OSheet).Cells(NSLRow + 1, 7), Sheets(OSheet).Cells(NSLRow + 1, 8)).Address
Sheets(NSheet).Range(StrX).Value = Range(StrX).Value
End If
Next i
End Sub
This will work for your example:
Sub stackv2()
Dim OSheet As Worksheet
Dim NSheet As Worksheet
Dim i As long
Dim LRow As long
Dim NSLRow As Long
Dim cpyClm As Long
Set OSheet = Sheets("Sheet1") 'change to your Old Sheet Name
Set NSheet = Sheets("Sheet7") 'change to your New Sheet Name
cpyClm = 1 'change this to the number columns desired
'Finds last row in the New Sheet
NSLRow = NSheet.Cells(NSheet.Rows.Count, 1).End(xlUp).Row
With OSheet
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Last Row in Old Sheet
For i = 2 To LRow
'If cell has "First Name then..."
If InStr(LCase(.Cells(i, 1)), LCase("first name")) Then
NSLRow = NSLRow + 1 'moves to new row every time this is true.
NSheet.Cells(NSLRow, 1).Resize(, cpyClm).Value = .Cells(i, "A").Resize(, cpyClm).Value
ElseIf InStr(LCase(Cells(i, 1)), LCase("last name")) Then
NSheet.Cells(NSLRow, 1 + cpyClm).Resize(, cpyClm).Value = .Cells(i, "A").Resize(, cpyClm).Value
ElseIf InStr(LCase(Cells(i, 1)), LCase("middle name")) Then
NSheet.Cells(NSLRow, 1 + (cpyClm * 2)).Resize(, cpyClm).Value = .Cells(i, "A").Resize(, cpyClm).Value
End If
Next i
End With
End Sub
But because we don't know what your true data looks like I put the ability to change the number of columns to copy. Also since your example does not include column A, and your explanation wants it you will need to change the column in the cells to 1 instead of 2
If this does not work or help you figure out how to adjust it on your own, you will need to post an actual representation of your data and desired output.
Related
the code below works fine apart from one thing, the names are copied to the second sheet in the same position as they are in in the first sheet so I end up with this.
As you can see there are loads of blanks, what I need it to end up like is,
This
There are three parts to the code as you can see
1 gather names and status
2 test the availability of the person and write their name to the second sheet if they are available
3 clear out the blanks
Is there any way I can amend the line;
Activecell.offset to place the name in the next available cell in each column as it cycles through?
I can’t use the “clear the blanks” as it screws up all the buttons positions in the second sheet
Code
Option Explicit
Sub Copy_all_available_names_to_sorted_sidesmen_50()
'record all the names and availability into a single array
Dim AllData() As Variant
Dim Name As Long, Status As Long
Dim Storedname As String
Dim Storedstatus As String
Dim nameindex As Long
Sheets("Everyones Availability").Select
Name = Range("A3", Range("A3").End(xlDown)).Count - 1
Status = Range("a3", Range("a3").End(xlToRight)).Count - 1
ReDim AllData(0 To Name, 0 To Status)
For Name = LBound(AllData, 1) To UBound(AllData, 1)
For Status = LBound(AllData, 2) To UBound(AllData, 2)
AllData(Name, Status) = Range("A3").Offset(Name, Status).Value
Next Status
Next Name
Sheets("Sorted sidesmen").Select
Range("A3").Select
For Name = LBound(AllData, 1) To UBound(AllData, 1)
For Status = LBound(AllData, 2) To UBound(AllData, 2)
Storedname = AllData(Name, 0)
Storedstatus = AllData(Name, Status)
If Storedstatus = "Available" Then
ActiveCell.Offset(1, 0)(Name, Status).Value = Storedname
End If
Next Status
Next Name
Dim rng As Range
On Error GoTo NoBlanksFound
Set rng = Range("a3:z46").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
rng.Rows.Delete shift:=xlShiftUp
NoBlanksFound:
MsgBox "All Blanks have been removed"
End Sub
Thank you for looking and help you may be able to give
This should work
Option Explicit
Public Sub CopyAllAvailableNamesToSortedSidesmen50()
Dim wsEA As Worksheet: Set wsEA = ThisWorkbook.Worksheets("Everyones Availability")
Dim wsSS As Worksheet: Set wsSS = ThisWorkbook.Worksheets("Sorted sidesmen")
Dim topEAcel As Range: Set topEAcel = wsEA.Cells(3, "A")
Dim topSScel As Range: Set topSScel = wsSS.Cells(3, "A")
Dim lrEA As Long: lrEA = wsEA.Cells(wsEA.Rows.Count, "A").End(xlUp).Row
Dim lcEA As Long: lcEA = wsEA.Cells(1, wsEA.Columns.Count).End(xlToLeft).Column
wsSS.Range(topSScel, wsSS.Cells(lrEA, lcEA)).ClearContents 'clear Sorted sidesmen
Dim arrEA As Variant: arrEA = wsEA.Range(topEAcel, wsEA.Cells(lrEA, lcEA))
Dim arrSS As Variant: arrSS = wsSS.Range(topSScel, wsSS.Cells(lrEA, lcEA))
Dim rEA As Long, cEA As Long, rSS As Long
For cEA = 2 To lcEA 'by columns
rSS = 1
For rEA = 1 To lrEA - 2 'by rows
If arrEA(rEA, cEA) = "Available" Then
arrSS(rSS, cEA) = arrEA(rEA, 1) 'copy available names
rSS = rSS + 1
End If
Next
Next
wsSS.Range(topSScel, wsSS.Cells(lrEA, lcEA)).Value2 = arrSS 'paste in wsSS
End Sub
Sheet1 ("Everyones Availability")
Sheet2 ("Sorted sidesmen")
Key items in code:
Last Row on "Everyones Availability": lrEA
Last Col on "Everyones Availability": lcEA
lrEA = wsEA.Cells(wsEA.Rows.Count, "A").End(xlUp).Row
lcEA = wsEA.Cells(1, wsEA.Columns.Count).End(xlToLeft).Column
Note: initial methods (xlDown, and xlToRight) were causing issues with empty cells
- All data on "Everyones Availability": arrEA = Variant Array (copy from)
- All data on "Sorted Sidesmen": arrSS = Variant Array (copy to; empty before copy)
arrEA = wsEA.Range(topEAcel, wsEA.Cells(lrEA, lcEA))
arrSS = wsSS.Range(topSScel, wsSS.Cells(lrEA, lcEA)) 'Same size as arrEA
If arrEA(rEA, cEA) = "Available" Then
arrSS(rSS, cEA) = arrEA(rEA, 1) 'copy names
rSS = rSS + 1 'separate row counter for "Sorted sidesmen", increment only if "Available"
End If
Could you simply sort the output in the final sheet?
Option Explicit
Public Sub Ordering()
Dim col As Range, lastRow As Long
With ThisWorkbook.Worksheets("Sheet1") 'change as appropriate
lastRow = .UsedRange.SpecialCells(xlLastCell).Row
For Each col In Intersect(Range("A:D"), .UsedRange).Columns
.Range(.Cells(3, col.Column), .Cells(lastRow, col.Column)).Sort Key1:=.Range(.Cells(3, col.Column), .Cells(lastRow, col.Column)), Order1:=xlAscending, Header:=xlNo ' 'Sort to ensure in order
Next col
End With
End Sub
Before:
After:
This code should do what you need:
Assuming your source sheet is called "Everyones Availability" and new sheet "Sorted sidesmen"
Sub copy_to_newsheet()
Dim i, j, lr, lc, newlr, newlc As Long
Sheets("Sorted sidesmen").Cells.ClearContents
lr = Sheets("Everyones Availability").Range("A10000").End(xlUp).Row '' your last row
lc = Sheets("Everyones Availability").Range("A1").End(xlToRight).Column '' your last column
Sheets("Everyones Availability").Range(Cells(1, 1), Cells(2, lc)).Copy
Sheets("Sorted sidesmen").Cells(1, 1).PasteSpecial Paste:=xlPasteValues
For j = 1 To lc
For i = 3 To lr
Sheets("Sorted sidesmen").Select
Cells(1, j).Select
newlr = Selection.End(xlDown).Row '' your new last row
newlc = Selection.End(xlToRight).Column '' your new last column
If Sheets("Everyones Availability").Cells(i, j).Value = "" Then GoTo thenexti
Sheets("Everyones Availability").Cells(i, j).Copy
Sheets("Sorted sidesmen").Cells(newlr + 1, j).PasteSpecial Paste:=xlPasteValues
thenexti:
Next
Next
End Sub
I have a value in column C which in some cases are duplicated, where there are duplicates I want it to look in column Z for the corresponding ID if none exist I want it to check where whether any other values in column C have a value in Column Z and then add the missing values into column Z accordingly:
Column C Column Z
45519 Blank*
45519 1
456 2
456 *Blank
Expected result:
Column C: Column Z
45519 1
45519 1
456 2
456 2
Stackoverflow Code I have adapted to use 1 and 24 respectively.
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("transactions")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim dataArr()
dataArr = ws.Range("C1:Z" & lastRow).Value
Dim currentRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 2)
If Not IsEmpty(dataArr(currentRow, 2)) And Not dict.Exists(dataArr
(currentRow, 1)) Then
dict.Add dataArr(currentRow, 1), dataArr(currentRow, 2)
End If
Next currentRow
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
If IsEmpty(dataArr(currentRow, 2)) Then
dataArr(currentRow, 2) = dict(dataArr(currentRow, 1))
End If
Next currentRow
ws.Range("C1").Resize(UBound(dataArr, 1), UBound(dataArr, 2)) = dataArr
End Sub
I am receiving no result in column Z as a result of this
Try this. Amended column references as per comments, plus I think your first loop was unnecessarily long. You'll need to change the 24s if your array is actually of a different size.
Option Explicit
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("transactions")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim dataArr()
dataArr = ws.Range("C1:Z" & lastRow).Value
Dim currentRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
If Not IsEmpty(dataArr(currentRow, 24)) And Not dict.Exists(dataArr(currentRow, 1)) Then
dict.Add dataArr(currentRow, 1), dataArr(currentRow, 24)
End If
Next currentRow
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
If IsEmpty(dataArr(currentRow, 24)) Then
dataArr(currentRow, 24) = dict(dataArr(currentRow, 1))
End If
Next currentRow
ws.Range("C1").Resize(UBound(dataArr, 1), UBound(dataArr, 2)) = dataArr
End Sub
Alternative method
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("transactions")
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim r As Range, r1 As Range, s As String
For Each r In ws.Range("Z1:Z" & lastRow).SpecialCells(xlCellTypeBlanks)
Set r1 = ws.Range("C1:C" & lastRow).Find(ws.Cells(r.Row, "C"), , , xlWhole)
If Not r1 Is Nothing Then
s = r1.Address
Do Until r1.Row <> r.Row
Set r1 = ws.Range("C1:C" & lastRow).FindNext(r1)
If r1.Address = s Then Exit Do
Loop
r.Value = ws.Cells(r1.Row, "Z")
End If
Next r
End Sub
There is some tidying up to do. Currently assumes data starts in row 2.
Option Explicit
Public Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("transactions")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim unionRng As Range
Set unionRng = Union(ws.Range("C2:C" & lastRow), ws.Range("Z2:Z" & lastRow))
Dim dataArray()
Dim numberOfColumns As Long
numberOfColumns = unionRng.Areas.Count
ReDim dataArray(1 To lastRow, 1 To numberOfColumns) '1 could come out into variable startRow
Dim currRow As Range
Dim columnToFill As Long
For columnToFill = 1 To numberOfColumns
For Each currRow In unionRng.Areas(columnToFill)
dataArray(currRow.Row - 1, columnToFill) = currRow 'assume data starts in row 1 otherwise if 2 then currRow.Row -1 etc
Next currRow
Next columnToFill
Dim currentRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For currentRow = LBound(dataArray, 1) To UBound(dataArray, 1)
If Not IsEmpty(dataArray(currentRow, 2)) And Not dict.Exists(dataArray(currentRow, 1)) Then
dict.Add dataArray(currentRow, 1), dataArray(currentRow, 2)
End If
Next currentRow
For currentRow = LBound(dataArray, 1) To UBound(dataArray, 1)
If IsEmpty(dataArray(currentRow, 2)) Then
dataArray(currentRow, 2) = dict(dataArray(currentRow, 1))
End If
Next currentRow
ws.Range("Z2").Resize(UBound(dataArray, 1), 1) = Application.Index(dataArray, 0, 2)
End Sub
you could very simply go like follows
Option Explicit
Sub main()
Dim cell As Range, IdsRng As Range
With Worksheets("transactions") 'reference wanted sheet
Set IdsRng = .Range("Z2", .Cells(.Rows.Count, "Z").End(xlUp)).SpecialCells(XlCellType.xlCellTypeConstants, xlNumbers) 'get all IDs from its column Z cells with constant numeric value
With .Range("C1", .Cells(.Rows.Count, "C").End(xlUp)) 'reference referenced sheet column C cells from row 1 (header) down to last not empty one
For Each cell In IdsRng 'loop through all IDs
.AutoFilter Field:=1, Criteria1:=cell.Offset(, -23).value ' filter referenced cells on 1st column with passed ID content 'filter referenced range with current ID
.Offset(1, 23).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).value = IdsRng.value 'write all filtered cells corresponding values in column Z with current ID
Next
End With
.AutoFilterMode = False
End With
End Sub
I don't know why this function doesn't loop through the worksheets , what am I missing ?
I've gone through Almost every resource I can find both on stack overflow and Google but could not find an answer that I could implement.
I've tried looping through worksheet numbers however that didn't work so I am now attempting to loop through worksheet names. This also does not work.
I'm pretty sure it's a small error but I could not find the cause after days of searching.
Sub CreateUniquesList()
Dim WS_Count As Integer 'number of WorkSheets
Dim Sheet As Integer 'WorkSheet number
Dim Uniques() As String 'Array of all unique references
Dim UniquesLength As Integer
Dim size As Integer 'number of items to add to Uniques
Dim Row As Integer 'row number
Dim Column As Variant 'column number
Dim Columns As Variant
Dim blanks
Dim LastRow As Integer
Dim i As Integer
Dim wks As Variant, wksNames() As String
WS_Count = ActiveWorkbook.Worksheets.Count
ReDim wksNames(WS_Count - 1)
i = 0
For Each wks In Worksheets
wksNames(i) = wks.Name
i = i + 1
Next
Columns = Array(3, 4, 8, 11, 12, 17, 18)
ReDim Uniques(0)
Uniques(0) = "remove this item"
WS_Count = ActiveWorkbook.Worksheets.Count
' For Sheet = 1 To WS_Count
For Each wks In wksNames
For Each Column In Columns
' LastRow = ActiveWorkbook.Worksheets(Sheet).Cells(Rows.Count, Column).End(xlUp).Row
' size = WorksheetFunction.CountA(Worksheets(Sheet).Columns(Column)) - 1
LastRow = ActiveWorkbook.Worksheets(wks).Cells(Rows.Count, Column).End(xlUp).Row
size = WorksheetFunction.CountA(Worksheets(wks).Columns(Column)) - 1
UniquesLength = UBound(Uniques) - LBound(Uniques) + 1
ReDim Preserve Uniques(UniquesLength + size - 1)
blanks = 0
i = 1
For Row = LastRow To 2 Step -1
If Cells(Row, Column).Value <> "" Then
Uniques(UniquesLength + i - 1 - blanks) = Cells(Row, Column).Value
Else
blanks = blanks + 1
End If
i = i + 1
Next Row
Next Column
Next wks
' Next Sheet
'remove first unique element
For i = 1 To UBound(Uniques)
Uniques(i - 1) = Uniques(i)
Next i
ReDim Preserve Uniques(UBound(Uniques) - 1)
End Sub
I took a look at the code and have rewritten a fair portion of it as I don't think a lot of it was necessary (probably leftover from your attempts to make things work). Try this, and if you don't understand any of it, post a comment and I'll explain further.
Sub CreateUniquesList()
Dim Uniques() As String 'Array of all unique references
Dim Row As Integer 'row number
Dim Column As Variant 'column number
Dim Columns As Variant
Dim LastRow As Integer
Dim wks As Worksheet
Columns = Array(3, 4, 8, 11, 12, 17, 18)
ReDim Uniques(0)
For Each wks In ThisWorkbook.Worksheets
For Each Column In Columns
LastRow = wks.Cells(wks.Rows.Count, Column).End(xlUp).Row
For Row = LastRow To 2 Step -1
If wks.Cells(Row, Column).Value <> "" Then
Uniques(UBound(Uniques)) = wks.Cells(Row, Column).Value ' set the last element of the array to the value
ReDim Preserve Uniques(UBound(Uniques)+1) ' increment the size of the array
End If
Next Row
Next Column
Next wks
' lose the last element of the array as it's one larger than it needs to be
ReDim Preserve Uniques(UBound(Uniques) - 1)
End Sub
Try this
WS_Count = ActiveWorkbook.Worksheets.Count
' For Sheet = 1 To WS_Count
For Each wks In Worksheets
For Each Column In Columns
'LastRow = ActiveWorkbook.Worksheets(Sheet).Cells(Rows.Count,column).End(xlUp).Row
'size = WorksheetFunction.CountA(Worksheets(Sheet).Columns(Column)) - 1
LastRow = ActiveWorkbook.Worksheets(wks.Name).Cells(Rows.Count,Column).End(xlUp).Row
size = WorksheetFunction.CountA(Worksheets(wks.Name).Columns(Column)) - 1
UniquesLength = UBound(Uniques) - LBound(Uniques) + 1
ReDim Preserve Uniques(UniquesLength + size - 1)
blanks = 0
i = 1
For Row = LastRow To 2 Step -1
If Cells(Row, Column).Value <> "" Then
Uniques(UniquesLength + i - 1 - blanks) = Cells(Row, Column).Value
Else
blanks = blanks + 1
End If
i = i + 1
Next Row
Next Column
Next wks
In the pictures below, I have a source page that is formatted with a device and attributes. I would like to create a macro which copies that source data and pastes it in the format of the target sheet. Ultimately the target sheet would be empty and would populate only when running the macro.
Source page and target page
I am a newb at this. I've tried using the following code from another stack overflow question, but it doesn't do what I want.
Sub ColumnCopy()
Dim lastRow As Long
Dim lastRow As Long
Dim lastCol As Long
Dim colBase As Long
Dim tRow As Long
Dim source As String
Dim target As String
source = "source" 'Set your source sheet here
target = "target" 'Set the Target sheet name
tRow = 2 'Define the start row of the target sheet
'Get Last Row and Column
lastRow = Sheets(source).Range("A" & Rows.Count).End(xlUp).Row
lastCol = Sheets(source).Cells(2, Columns.Count).End(xlToLeft).Column
tRow = 2
colBase = 2
Do While colBase < lastCol
For iRow = 2 To lastRow
Sheets(target).Cells(tRow, 1) = Sheets(source).Cells(1, tRow)
Sheets(target).Cells(tRow, 2) = Sheets(source).Cells(2, tRow)
Sheets(target).Cells(tRow, 3) = Sheets(source).Cells(3, tRow)
Sheets(target).Cells(tRow, 4) = Sheets(source).Cells(4, tRow)
Sheets(target).Cells(tRow, 5) = Sheets(source).Cells(5, tRow)
Sheets(target).Cells(tRow, 6) = Sheets(source).Cells(6, tRow)
tRow = tRow + 1
Next iRow
colBase = colBase + 1 'Add 4 to the Column Base. This shifts the loop over to the next Row set.
Loop
End Sub
Thanks,
MJ
I currently have an array which I populate and paste in a sheet named "T1" using a macro. My current macro uses the rowcount function to determine the used rows and pastes the array from the next available row.
The problem I am having is that when I paste this array multiple times, the arrays need to be spaced by a row so that i can differentiate different submissions. This is what I have so far, and I was hoping someone could help me with this:
Sub CopyData()
Dim Truearray() As String
Dim cell As Excel.Range
Dim RowCount1 As Integer
Dim i As Integer
Dim ii As Integer
Dim col As Range
Dim col2 As Range
i = 0
ii = 2
RowCount1 = DHRSheet.UsedRange.Rows.Count
Set col = DHRSheet.Range("I1:I" & RowCount1)
For Each cell In col
If cell.Value = "True" Then
Dim ValueCell As Range
Set ValueCell = Cells(cell.Row, 3)
ReDim Preserve Truearray(i)
Truearray(i) = ValueCell.Value
Dim siblingCell As Range
Set siblingCell = Cells(cell.Row, 2)
Dim Siblingarray() As String
ReDim Preserve Siblingarray(i)
Siblingarray(i) = DHRSheet.Name & "$" & siblingCell.Value
i = i + 1
End If
Next
Dim RowCount2 As Integer
RowCount2 = DataSheet.UsedRange.Rows.Count + 1
For ii = 2 To UBound(Truearray)
DataSheet.Cells(RowCount2 + ii, 2).Value = Truearray(ii)
Next
For ii = 2 To UBound(Siblingarray)
DataSheet.Cells(RowCount2 + ii, 1).Value = Siblingarray(ii)
Next
DataSheet.Columns("A:B").AutoFit
MsgBox ("Data entered has been successfully validated & logged")
End Sub
If you Offset two rows from the bottom cell, you will leave a blank row of separation. You should also consider filling the whole array as base 1 and writing it to DataSheet in one shot.
Sub CopyData2()
Dim rCell As Range
Dim aTrues() As Variant
Dim rRng As Range
Dim lCnt As Long
'Define the range to search
With DHRSheet
Set rRng = .Range(.Cells(1, 9), .Cells(.Rows.Count, 9).End(xlUp))
End With
'resize array to hold all the 'trues'
ReDim aTrues(1 To Application.WorksheetFunction.CountIf(rRng, "True"), 1 To 2)
For Each rCell In rRng.Cells
If rCell.Value = "True" Then
lCnt = lCnt + 1
'store the string from column 2
aTrues(lCnt, 1) = DHRSheet.Name & "$" & rCell.Offset(0, -7).Value
'store the value from column 3
aTrues(lCnt, 2) = rCell.Offset(0, -6).Value
End If
Next rCell
'offset 2 from the bottom row to leave a row of separation
With DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp).Offset(2, 0)
'write the stored information at one time
.Resize(UBound(aTrues, 1), UBound(aTrues, 2)).Value = aTrues
End With
End Sub