copy data into next available blank cell excel vba - vba

Question

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

Answer 1

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

Answer 2

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:

Answer 3

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