Copy Data from Particular sheets and save in existing sheet"Draft" - excel

I have sheets 1 2 3 4 and all contains the same set of columns(There are other tabs as well in the book with different set of columns).
I need to copy all tab data in to one sheet which is already there in the workbook named "Draft".
I have found this code and tried:
Sub CopyFromWorksheets()
Dim wrk As Workbook
'Workbook object - Always good to work with object variables
Dim sht As Worksheet
'Object for handling worksheets in loop
Dim trg As Worksheet
'Master Worksheet
Dim rng As Range
'Range object
Dim colCount As Integer
'Column count in tables in the worksheets
Set wrk = ActiveWorkbook
'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
which is working fine but creating new tab and copied data from all tabs irrespective of required tab.
which is working fine but creating new tab and copied data from all tabs irrespective of required tab.

Without any testing, and if i understand correctly what you are trying to achieve (copy your Sheet 1,2,3,4 to Draft sheet), please see below the modified code (from your working code):
Sub CopyFromWorksheets()
Dim wrk As Workbook
'Workbook object - Always good to work with object variables
Dim sht As Worksheet
'Object for handling worksheets in loop
Dim trg As Worksheet
'Master Worksheet
Dim rng As Range
'Range object
Dim colCount As Integer
'Column count in tables in the worksheets
Set wrk = ActiveWorkbook
'Working in active workbook
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets("Draft")
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Name = "Sheet1" or sht.Name = "Sheet2" or sht.Name = "Sheet3" or sht.Name = "Sheet4" Then
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub

Related

VBA Embed Loop within a Loop

I'm trying to embed a loop within a loop. I have a workbook with multiple worksheets. What I'm trying to do is identify the range of each worksheet in my workbook and add an additional worksheet for each sheet to create a pivot table. I'm having trouble with embedding my For Loop for worksheet creation in the for loop of setting the worksheet ranges. My current code creates the pivot worksheets and the pivot tables but they all use the range of one worksheet only.
'set pivot table data range
Dim sht As Worksheet
Set wb = ActiveWorkbook
For Each sht In ActiveWorkbook.Worksheets
Set dataRG = sht.Range("A4").CurrentRegion
Next
'verify pvt table sheets in wb
Dim SheetNames() As Variant
SheetNames() = Array("Test1 Pivot", "Test2 Pivot", "Test3
Pivot", "Test4 Pivot", "Test5 Pivot", "Test6 Pivot",
"Test7 Pivot")
For n = LBound(SheetNames) To UBound(SheetNames)
Set pvtWs = Nothing 'reset ws to Nothing
On Error Resume Next 'ignore errors
Set pvtWs = wb.Worksheets(SheetNames(n)) 'try to set `ws`
On Error GoTo 0 'stop ignoring errors
If pvtWs Is Nothing Then 'add a sheet
Set pvtWs = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
pvtWs.Name = SheetNames(n)
'pivot cache and create pivot
Set pvtCache = ActiveWorkbook.PivotCaches.Create(SourceType:-xlDatabase,SourceData:=dataRG)
Set pvtTable = pvtCache.CreatePivotTable(TableDestination:=pvtWs.Cells(1,1))
pvtTable.Name = PvtNames(n)
End If
Next
It would be cleaner to loop over a list of data sheet names, and use that to drive the logic.
So something like this (untested):
Option Explicit
Sub CheckPivots()
Dim wb As Workbook, nm, wsPivot As Worksheet, wsData As Worksheet
Dim SheetNames, pvNm, pvtCache As PivotCache, pvtTable As PivotTable
Dim rngData As Range
'The names of your sheets with data
SheetNames = Array("Team1", "Team2", "Team3", _
"Team4", "Team5", "Team6", "Team7")
Set wb = ActiveWorkbook
For Each nm In SheetNames
Set wsData = GetSheet(wb, nm)
If Not wsData Is Nothing Then 'data sheet exists?
pvNm = nm & " Pivot" 'name for the pivot sheet
Set wsPivot = GetSheet(wb, pvNm)
If wsPivot Is Nothing Then 'need to add a pivot sheet?
Set wsPivot = wb.Worksheets.Add(after:=wsData)
wsPivot.Name = pvNm
'pivot cache and create pivot
Set rngData = wsData.Range("A4").CurrentRegion
Set pvtCache = wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngData)
Set pvtTable = pvtCache.CreatePivotTable(TableDestination:=wsPivot.Cells(1, 1))
pvtTable.Name = "pt_" & nm 'based on source data sheet name
End If
End If
Next nm 'next data sheet name
End Sub
'Return worksheet `nm` from workbook `wb`, or Nothing if no sheet with that name
Function GetSheet(wb As Workbook, wsName) As Worksheet
On Error Resume Next
Set GetSheet = wb.Worksheets(wsName)
End Function

Dynamically Populate All Sheets in Excel Workbook to a Master Sheet

So I have a workbook with multiple sheets. All contain the same columns but just different categorical data. I want to grab all the data from those sheets and display/populate to a master sheet in the workbook.
I have tried different methods, but none of them are dynamic. The amount of data can be changed (+/-, either more rows or less rows) in each sheet. Each method I have found seems to be a static solution.
One example is to use the Consolidate option under the data tab, and add the respective reference/range for each sheet you would like to add (not dynamic).
Another option I found was a VBA macro, which populates the headers over and over, which I do not want to happen either, I want them all under the same header (Since the columns are already the same)
Sub Combine()
'UpdatebyExtendoffice20180205
Dim I As Long
Dim xRg As Range
Worksheets.Add Sheets(1)
ActiveSheet.Name = "Combined"
For I = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
Next
End Sub
Is this achievable?
Sheet 1
Sheet 2
Master Sheet Should Be:
But actually returns the following:
Will this constantly run each time the workbook is closed/opened/updated if it is a macro enabled workbook?
Consolidate All Worksheets
It is assumed that the Combined worksheet already exists with at least the headers which will stay intact.
To make it more efficient, only values are copied (no formats or formulas).
It will utilize the Worksheet Activate event: each time you activate (select) the combined worksheet, the data will automatically be updated.
Sheet Module of the Combined worksheet e.g. Sheet10(Combined)
Option Explicit
Private Sub Worksheet_Activate()
CombineToMaster
End Sub
Standard Module e.g. Module1
Option Explicit
Sub CombineToMaster()
Const dName As String = "Combined"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim drrg As Range
With dws.UsedRange
If .Rows.Count = 1 Then
Set drrg = .Offset(1)
Else
.Resize(.Rows.Count - 1).Offset(1).Clear
Set drrg = .Resize(1).Offset(1)
End If
End With
Dim sws As Worksheet
Dim srg As Range
Dim drg As Range
Dim rCount As Long
For Each sws In wb.Worksheets
If sws.Name <> dName Then
With sws.UsedRange
rCount = .Rows.Count - 1
If rCount > 0 Then
Set srg = .Resize(rCount).Offset(1)
drrg.Resize(rCount).Value = srg.Value
Set drrg = drrg.Offset(rCount)
End If
End With
End If
Next sws
End Sub
VBA Solution
Sub Combine()
Dim wsCombine As Worksheet: Set wsCombine = GetSheetCombine
Dim dataSheets As Collection: Set dataSheets = GetDataSheets
' Copy Header
dataSheets.Item(1).UsedRange.Rows(1).Copy
wsCombine.Range("A1").PasteSpecial xlPasteAll
wsCombine.Range("A1").PasteSpecial xlPasteColumnWidths
Application.CutCopyMode = False
' Copy data
Dim rngDest As Range: Set rngDest = wsCombine.Range("A2")
Dim srcRng As Range
Dim ws As Worksheet
For Each ws In dataSheets
' Drop header row
With ws.UsedRange
Set srcRng = .Offset(1, 0).Resize(.Rows.Count - 1)
End With
srcRng.Copy rngDest
Set rngDest = rngDest.Offset(srcRng.Rows.Count)
Next ws
Application.CutCopyMode = False
MsgBox "Done!", vbInformation
End Sub
Private Function GetSheetCombine() As Worksheet
Dim ws As Worksheet
With Worksheets
On Error Resume Next
Set ws = .Item("Combine")
On Error GoTo 0
If ws Is Nothing Then
Set ws = .Add(Before:=.Item(1))
ws.Name = "Combine"
Else
ws.Cells.Clear ' clear any existing data
End If
End With
Set GetSheetCombine = ws
End Function
Private Function GetDataSheets() As Collection
Dim Result As New Collection
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "Combine" Then Result.Add ws
Next ws
Set GetDataSheets = Result
End Function
As to your question "Will this run every time macro enabled workbook is open?".
No. You will need to put this in a VBA module and run it every time you need, via the Macro dialog (View->Macros), or link a button to it.

Copying unlocked cells from many sheets to other sheets with the same name in another workbook

The intent is to copy all unlocked cells in multiple sheets except "Sheet1" from Workbook1 (origin file) to Workbook2 (destination file) which contains worksheets with the same names as Workbook1.
Workbook1 is a checklist and Workbook2 is an updated version with additions of new worksheets or extra unlocked cells. The workbook and worksheet names are different from above but have renamed everything for simplicity.
I put some code together:
Sub ImportData()
Dim vFile As Variant, wbCopyTo As Workbook, wsCopyTo As Worksheet, _
wbCopyFrom As Workbook, wsCopyFrom As Worksheet, WorkRng As Range, _
OutRng As Range, Rng As Range
Application.ScreenUpdating = False
Set wbCopyTo = ActiveWorkbook 'sets Workbook2 to destination file
'this allows user to select old file Workbook1
' - the workbook name may be different in practice
' hence the ability to choose file
vFile = Application.GetOpenFilename("All Excel Files (*.xls*)," & _
"*.xls*", 1, "Select your old file", "Open", False)
If TypeName(vFile) = "Boolean" Then
Exit Sub 'check file selected is okay to use else exits sub
Else
Set wbCopyFrom = Workbooks.Open(vFile)
End If 'sets Workbook1 to origin file
For Each Worksheet In wbCopyFrom.Worksheets
'should loop each worksheet, I think the error is part of this For statement
If Worksheet.Name <> "Sheet1" Then
On Error Resume Next
Set wsCopyFrom = Worksheet 'sets Sheet2 to origin sheet
'sets sheet matching name on previous line in Workbook2
' to destination sheet
Set wsCopyTo = wbCopyTo.Worksheets(Worksheet.Name)
wbCopyFrom.Activate
wsCopyFrom.Select 'selects origin sheet
Set WorkRng = wsCopyFrom.UsedRange
For Each Rng In WorkRng
If Rng.Locked = False Then
If OutRng.Count = 0 Then
Set OutRng = Rng
Else
Set OutRng = Union(OutRng, Rng)
End If
End If
Next
'a loop I found to pick all unlocked cells,
' seems to work fine for first sheet
If OutRng.Count > 0 Then OutRng.Select
Dim rCell As Range
For Each rCell In Selection.Cells
rCell.Copy Destination:=wsCopyTo.Cells(rCell.Row, rCell.Column)
'a loop to copy all unlocked cells exactly as is
' in terms of cell reference on sheet,
' seems to work fine for first sheet
Next rCell
End If
'should go to Sheet3 next, seems to go to the sheet
' but then doesn't select any unlocked cells nor copy anything across
Next Worksheet
wbCopyFrom.Close SaveChanges:=False 'closes origin file Workbook1
Application.ScreenUpdating = True
End Sub
It will select and copy all unlocked cells from "Sheet2" in Workbook1 to "Sheet2" in Workbook2, however, it will not cycle through all of the sheets necessary ("Sheet3" onwards).
it's possible your use of On Error Resume Next is masking problems
use something other than Worksheet as your For Each loop variable name
you don't reset OutRng after each worksheet
Try something like this:
Sub ImportData()
Dim vFile As Variant, wbCopyTo As Workbook, wsCopyTo As Worksheet, _
wbCopyFrom As Workbook, OutRng As Range, c As Range, wsCopyFrom As Worksheet
Application.ScreenUpdating = False
Set wbCopyTo = ActiveWorkbook 'sets Workbook2 to destination file
vFile = Application.GetOpenFilename("All Excel Files (*.xls*)," & _
"*.xls*", 1, "Select your old file", "Open", False)
If TypeName(vFile) = "Boolean" Then Exit Sub
Set wbCopyFrom = Workbooks.Open(vFile)
For Each wsCopyFrom In wbCopyFrom.Worksheets
If wsCopyFrom.Name <> "Sheet1" Then
Set wsCopyTo = wbCopyTo.Worksheets(wsCopyFrom.Name)
Set OutRng = UsedRangeUnlocked(wsCopyFrom)
If Not OutRng Is Nothing Then
For Each c In OutRng
c.Copy wsCopyTo.Range(c.Address)
Next c
End If
End If
Next wsCopyFrom
wbCopyFrom.Close SaveChanges:=False 'closes origin file Workbook1
Application.ScreenUpdating = True
End Sub
'return a range containing all unlocked cells within the UsedRange of a worksheet
Function UsedRangeUnlocked(sht As Worksheet) As Range
Dim rngUL As Range, c As Range
For Each c In sht.UsedRange.Cells
If Not c.Locked Then
If rngUL Is Nothing Then
Set rngUL = c
Else
Set rngUL = Application.Union(rngUL, c)
End If
End If
Next c
Set UsedRangeUnlocked = rngUL
End Function

Modify a macro to copy and paste using range and retaining formula

I found the code below on this site which works perfectly once I referenced the appropriate cells etc. However, I tried to modify it to keep formulas but I am not having much luck. Any help is greatly appreciated.
Sub test()
Dim names As New Collection
Dim ws As Worksheet, ws1 As Worksheet
Dim wb As Workbook
Dim lastrow As Long
Dim cell As Range
Dim nm As Variant
Dim res As Range
Dim rngHeader As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
'change "A" to column with "Names"
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'change "A" to column with "Names"
For Each cell In .Range("A2:A" & lastrow)
On Error Resume Next
'collect unique names
names.Add CStr(cell.Value), CStr(cell.Value)
On Error GoTo 0
Next cell
'disable all filters
.AutoFilterMode = False
'change "A1:C1" to headers address of your table
Set rngHeader = .Range("A1:C1")
For Each nm In names
With rngHeader
'Apply filter to "Name" column
.AutoFilter Field:=1, Criteria1:=nm
On Error Resume Next
'get all visible rows
Set res = .Offset(2).Resize(lastrow - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
'if there is visible rows, create new WB
If Not res Is Nothing Then
'create new workbook
Set wb = Workbooks.Add
'add sheet with name form column "Names" ("Paul", "Nick" or etc)
wb.Worksheets.Add.name = nm
'delete other sheets from new wb
For Each ws1 In wb.Worksheets
If ws1.name <> nm Then ws1.Delete
Next
'copy/paste data
With wb.Worksheets(nm)
'copy headers
.Range("A1").Resize(, rngHeader.Columns.Count).Value = rngHeader.Value
'copy data
.Range("A2").Resize(res.Rows.Count, res.Columns.Count).Value = res.Value
End With
'save wb
wb.Close saveChanges:=True, Filename:=ThisWorkbook.Path & "\Spreadsheet_" & nm & ".xlsx"
Set wb = Nothing
End If
End With
Next
'disable all filters
.AutoFilterMode = False
End With
Set names = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There is a part in your code which states that it copies / pastes data:
'copy/paste data
With wb.Worksheets(nm)
'copy headers
.Range("A1").Resize(, rngHeader.Columns.Count).Formula = rngHeader.Formula
'copy data
.Range("A2").Resize(res.Rows.Count, res.Columns.Count).Formula = res.Formula
End With
If you copy the .Formula instead of the .Value then it should work. Give it a try and let us know.

VBA code to combine all worksheets into 1 worksheet except for the first worksheet

I have a well-working code which combines the data for all of the worksheets in a workbook. However, I need to exclude Workbook.Sheets(1) from the code but despite changing the code to start from the second sheet, it is still combining all the worksheets. My code is pasted below.
I included an if statement that if the sheet name includes "Week" then carry on command but that results in that portion of the code not taking place at all.
For Each sht In wrk.Worksheets
If LCase(sht.Name) = "Week" Then
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'This above portion is the one i am referring to
My Code is:
Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Set wrk = ActiveWorkbook 'Working in active workbook
Set sht = wrk.Sheets(2)
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'We don't want screen updating
Application.ScreenUpdating = False
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Sheets(2)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
If LCase(sht.Name) = "Week" Then
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
'Screen updating should be activated
Application.ScreenUpdating = True
End Sub
I think you forgot a case sensitivity in:
If (LCase(sht.Name) = "Week") Then
That LCase(sht.Name) = "Week" will be always False, because:
LCase("Week") = "week" '--> True
LCase("Week") = "Week" '--> False
So, use:
If (LCase(sht.Name) = "week") Then
or
If (LCase(sht.Name) = LCase("Week")) Then
And for including or containing of "Week" use Like operator instead of = like this:
If (LCase(sht.Name) Like "*" & LCase("Week") & "*" ) Then

Resources