Question

下面的代码除了一件事之外还可以正常工作，这些名字被复制到第二张纸上的位置和它们在第一张纸上的位置相同，所以我最终得到了这个。

正如你所看到的那样，有很多空白，我需要它最终结束，

此

您可以看到代码有三个部分

1收集姓名和状态

2测试该人的可用性并将其姓名写入第二张表（如果有的话）

3清除空白

我有什么方法可以修改这条线;

Activecell.offset将名称放在每个列中的下一个可用单元格中？

我无法使用“清除空白”，因为它会搞砸第二张中的所有按钮位置

代码

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

感谢您寻求帮助，也许能够给予

Answer 1

您可以简单地对最终工作表中的输出进行排序吗？

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

<强>之前：

<强>后：

Answer 2

此代码应该满足您的需求：

假设您的源表名为“Everyones Availability”和新表单“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

Answer 3

这应该有效

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”）

代码中的关键项：

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

将数据复制到下一个可用的空白单元格excel vba中

3 个答案: