如何使用 VBA 復制 excel 中的一列單元格，直到出現空白並將其粘貼到新工作表中？

Question

我希望在這里處理幾個問題：

我們有一個來自客戶的電子表格，其中包含相同日常工作表格的 150 個不同選項卡。 在每個工作表中，幸運的是在相同的位置，是 C4 中的日期和從 B10 開始進行的工作列表。（所進行的工作在許多單元格中有所不同；有些有 3 個，有些有 8 個等等......所以一個列表

編輯表，部分

我需要做的是，將完成的工作復制到數據庫表 B 列中，然后將 C4 中的日期（在工作表中）復制到 A 列（數據庫表的）中，對於所進行的每一項工作. （因此，如果執行了 5 項任務，它將在日期中復制到 A 列 5 次。然后我需要對所有選項卡執行此操作，因此它在一個列表中。

在 1 個單元格的作品列表下方有一個空白，然后是更多數據，這與上面相同......不確定 End(xlUp) 或 End(xldown) 是否可用。

多個選項卡宏 - 問題是它復制到每個選項卡，而不是單個選項卡

  Sub DateCLM()
    
    DateCLM Macro
    Date Column
    
    Dim xSh As Worksheet
        Application.ScreenUpdating = False
        For Each xSh In Worksheets
            xSh.Select
            Call RunCode
        Next
        Application.ScreenUpdating = True
    End Sub

目前正試圖解決這個問題並且沒有得到任何幫助。任何幫助將不勝感激。

馬特

Answer 1

如何使用 VBA 復制 excel 中的一列單元格，直到出現空白並將其粘貼到新工作表中？

這是我多年前提出的用於解決此問題的算法。

Create variables for the first and last cells in your range
Set the value of the first cell in the range, i.e. B10
Select the first cell in the range
While active cell is not empty
   select the next cell down
end while
select the range of cells between your two variables
---perform some action---

我無法訪問原始文件，多年來我也沒有使用過 VBA，但我給了它一個 go。 希望這會在正確的方向上為您提供幫助？

Sub selectRange()

    'Create variables for the first and last cells in your range
    Dim firstCell As Range
    Dim lastCell As Range
    
    'Set the value of the first cell in the range, i.e. B10
    firstCell = Range("B10")
    
    'Select the first cell in the range
    firstCell.Select
    firstCell.Activate
    
    'Loop while cell is empty
    While Not ActiveCell = ""
        ActiveCell.Offset(1, 0).Activate
    Wend
    
    'After empty cell is found, activate last non-empty cell
    ActiveCell.Offset(-1, 0).Activate
    lastCell = ActiveCell
    
    'Select the range of cells between your two variables
    ActiveSheet.Range(firstCell, lastCell).Select
    
    '---perform some action--- 
End Sub

Answer 2

從多個工作表復制

• 假設數據一致：
  • Database是與要處理的工作表在同一工作簿中的工作表，
  • 所有日期都在單元格C4中並且是實際日期，
  • 所有其他數據位於單元格B10到下方第一個空白單元格之前（上方）。
• 調整常量部分中的值。

編碼

Option Explicit

Sub copyFromMultipleWorksheets()
    
    Const wsName As String = "Database"
    Const wsCell As String = "A2"
    Const datesCell As String = "C4"
    Const worksFirstCell As String = "B10"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim wsCount As Long: wsCount = wb.Worksheets.Count
    
    ' Define Arrays.
    Dim Works As Variant: ReDim Works(1 To wsCount - 1)
    Dim Dates() As Date: ReDim Dates(1 To wsCount - 1)
    Dim RowsCount() As Long: ReDim RowsCount(1 To wsCount - 1)
    Dim OneValue As Variant: ReDim OneValue(1 To 1, 1 To 1)
    
    ' Declare additional variables.
    Dim ws As Worksheet ' Source Worksheet
    Dim rg As Range ' Source Range
    Dim rCount As Long ' Rows Count
    Dim tRows As Long ' Total Rows (for Data Array)
    Dim n As Long ' Worksheets, Dates, Works Arrays, RowCounts Counter
    
    For Each ws In wb.Worksheets
        If ws.Name <> wsName Then
            ' Define Works Range.
            With ws.Range(worksFirstCell)
                Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1)
                Set rg = rg.Find("", rg.Cells(rg.Rows.Count), xlFormulas)
                Debug.Print rg.Address
                Set rg = .Resize(rg.Row - .Row)
            End With
            ' Count, write date and count some more.
            n = n + 1
            Dates(n) = ws.Range(datesCell).Value
            rCount = rg.Rows.Count
            RowsCount(n) = rCount
            tRows = tRows + rCount
            ' Write values from Works Range to current array of Works Array.
            If rCount > 1 Then
                Works(n) = rg.Value
            Else
                Works(n) = OneValue: Works(n)(1, 1) = rg.Value
            End If
        End If
    Next ws
    
    ' Write values from arrays of Works Array to Data Array.
    Dim Data As Variant: ReDim Data(1 To tRows, 1 To 2)
    Dim i As Long, k As Long
    For n = 1 To n
        For i = 1 To RowsCount(n)
            k = k + 1
            Data(k, 1) = Dates(n)
            Data(k, 2) = Works(n)(i, 1)
        Next i
    Next n
    
    ' Write values from Data Array to Destination Range.
    With wb.Worksheets(wsName).Range(wsCell).Resize(, 2)
        Application.ScreenUpdating = False
        .Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
        .Resize(k).Value = Data
        Application.ScreenUpdating = True
    End With
    
    ' Inform user.
    MsgBox "Data transferred.", vbInformation, "Success"
  
End Sub