如何使用 VBA 复制 excel 中的一列单元格，直到出现空白并将其粘贴到新工作表中？

Question

I am looking to deal with a couple of problems here:

We have a spreadsheet from a client that consists of 150 odd tabs of the same daily work form. In each work form, thankfully in the same positions, are a date in C4 and a list of works carried out starting in B10.(the works carried out vary in a number of cells; some have 3 some have 8 etc... so a list

redacted sheet, partial

What I need to do is, copy the works carried out into the database sheet, Column B, then copy the date from C4 (in the works sheet) into column A (of the database sheet), for each one of the works carried out. (so if there are 5 tasks carried out it would copy in the date to Column A 5 times. I then need to do that for all the tabs, so it is in one list.

There is a gap below the list of works of 1 cell then more data, this is the same above... noit sure if End(xlUp) or End(xldown)would be usable.

multiple tabs macro - the issue is it copies to each tab, not a single tab

  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

Currently trying to figure this out and not getting anywhere.. any help would be appreciated.

Matt

Answer 1

How can I copy a column of cells in excel, with VBA, until there is a blank and paste it into a new sheet?

Here is an algorithm I came up with years ago to solve this problem.

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

I don't have access to the original file, nor have I used VBA for years, but I've given it a go. Hopefully this will give you a help in the right direction?

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

Copy From Multiple Worksheets

• It is assumed that the data is consistent:
  • Database is a worksheet in the same workbook as the worksheets to be processed,
  • all dates are in cell C4 and are actual dates,
  • all other data is located from cell B10 to before (above) the first blank cell below.
• Adjust the values in the constants section.

The Code

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