DPeter2101
New Member
- Joined
- Dec 15, 2004
- Messages
- 11
Hello,
I am not very good with coding but have managed to use what I find and tweak it to fit my needs quite often. However, in this case I can't seem to get what I need and can't find anything that will work for me. I would appreciate any assistance I can get.
I have a work book with multiple Worksheet. These Worksheet have data I would like to move to one Worksheet. The data is in the same places on every Worksheet but I do not need the whole row. I Just need selected cells throughout the Worksheet. These are the Cells I need to copy ("C2", "F2", "B5", "B6", "B7", "B8", "B9", "F4", "F6", "F8", "C14", "C16", "F14").
I found this code and adjusted it to copy the data from the Cells that I needed. However it will only copy from one Worksheet and not multiple.
To sum up what I’m looking to do.
1. Copy select cells from multiple worksheets to a Master Worksheet.
2. Have the code find the last unused row and start adding new data at that location
I am not very good with coding but have managed to use what I find and tweak it to fit my needs quite often. However, in this case I can't seem to get what I need and can't find anything that will work for me. I would appreciate any assistance I can get.
I have a work book with multiple Worksheet. These Worksheet have data I would like to move to one Worksheet. The data is in the same places on every Worksheet but I do not need the whole row. I Just need selected cells throughout the Worksheet. These are the Cells I need to copy ("C2", "F2", "B5", "B6", "B7", "B8", "B9", "F4", "F6", "F8", "C14", "C16", "F14").
I found this code and adjusted it to copy the data from the Cells that I needed. However it will only copy from one Worksheet and not multiple.
Code:
Sub test()
Dim LR As Long, i As Long, cls
cls = Array("C2", "F2", "B5", "B6", "B7", "B8", "B9", "F4", "F6", "F8", "C14", "C16", "F14")
With Sheets("Sheet2")
LR = WorksheetFunction.Max(6, .Range("A" & Rows.Count).End(xlUp).Row + 1)
For i = LBound(cls) To UBound(cls)
.Cells(LR, i + 1).Value = Sheets("Sheet1").Range(cls(i)).Value
Next i
End With
End Sub
I also found this code that copies from multiple worksheets but it copies ranges and not selected cells. It also deletes the master sheet each time it runs. I have been trying to use part of both codes to get what I need but have failed miserably..
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
Dim LR As Long, i As Long, cls
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
'Loop through all worksheets and copy the data to the
'summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
' Find the last row with data on the summary worksheet.
Last = LastRow(DestSh)
' Specify the range to place the data.
Set CopyRng = sh.Range("A1").CurrentRegion
' Test to see whether there are enough rows in the summary
' worksheet to copy all the data.
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
' This statement copies values and formats from each
' worksheet.
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
' Optional: This statement will copy the sheet
' name in the H column.
'DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End SubTo sum up what I’m looking to do.
1. Copy select cells from multiple worksheets to a Master Worksheet.
2. Have the code find the last unused row and start adding new data at that location
Last edited by a moderator:
