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
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
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
Database
is a worksheet in the same workbook as the worksheets to be processed, C4
and are actual dates,B10
to before (above) the first blank cell below.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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.