Looping through specific sheets in an excel work book and copying data in different work sheet - excel

I'm trying to copy information from several specific sheets in a workbook, without copying information from irrelevant sheets, to a single sheet called Merge. The name of the sheets where i want to copy the information from is: Summary, Summary(1)... Summary(n+1).
In addition, i want the copied information to be pasted after the last row with information and without deleting the header line.
The code i'm using is a mix and match from various answers in different Excel-VBA forums so it's not elegant and probably has lots of errors caused by my limited understanding of VBA and coding as a whole.
This is the code i currently have:
Sub Copy_1()
Dim SourceRange As Range, DestRange As Range
Dim DestSheet As Worksheet, Lr As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Deleting the information from sheet ñéëåí
Sheets("Merge").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
'loop through all worksheets and copy the data to the DestSh
For Each sh In ThisWorkbook.Worksheets
'Loop through all worksheets except the Merge worksheet and the
'Information worksheet, you can add more sheets to the array if you want.
If IsError(Application.Match(sh.Name, _
Array(DestSheet.Name, "Merge"), 0)) Then
'fill in the Source Sheet and range
'Set SourceRange = Sheets("Summary").Range("A2:L100")
Set SourceRange = sh.Range("A2:N100")
SourceRange.Copy
'Fill in the destination sheet and call the LastRow
'function to find the last row
Set DestSheet = Sheets("øéëåæ")
Lr = LastRow(DestSheet)
'With the information from the LastRow function we can
'create a destination cell and copy/paste the source range
Set DestRange = DestSheet.Range("A" & Lr + 1)
'Set DestRange = DestSheet.Range("A" & Last + 1)
'End If
'SourceRange.Copy DestRange
SourceRange.Copy
With DestSheet.Cells(2, Last + 1)
.PasteSpecial 8 ' Column width
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
I would greatly appreciate your help as i've already spent hours going through various answers on similar issues in different forums and trying to solve this on my own.
Thanks a lot!

Check it out,
Sub Button1_Click()
Dim ws As Worksheet, sh As Worksheet, pRng As Range
Set ws = Sheets("Merge")
For Each sh In Sheets
If sh.Name <> ws.Name Then 'if sheet name does not ="Merge"
If sh.Name <> "Jimmy Changa" Then 'just an example if you didn't want to include a sheet
sh.Range("A2:N100").Copy
Set pRng = ws.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
pRng.PasteSpecial Paste:=xlPasteFormats
pRng.PasteSpecial Paste:=xlPasteValues
End If
End If
Application.CutCopyMode = 0
Next sh
Columns("A:G").EntireColumn.AutoFit
End Sub

Related

Copying columns from multiple sheets into one sheet in the same workbook using VBA

My goal is to automatically copy a range of columns (A:C) from 40+ Excel Sheet into one Sheet located in the same workbook.
The structure of all sheets is identical. Columns consist of numeric values. I want the columns to be added to the right at each iteration (so the target sheet will be enriched horizontally with the data)
My attempt (see the code below) is not automated as if I have to specify Sheet Names and Target Cell where it is possible to copy the columns
Sub macro()
Sheets("Top").Select
Columns("A:C").Select
Selection.Copy
Sheets("Low").Select
Range("D1").Select
ActiveSheet.Paste
End Sub
Any help is appreciated! Thank you
Please, try the next code. It will iterate between all existing sheets and copy all rows of columns "D:K" from all sheets in one named "Destination" (starting from "A1"). If you need it to start from "D1" it would be easy to adapt the code:
Sub copyAllSheetsInOne()
Dim ws As Worksheet, sh As Worksheet, lastRow As Long, lastEmptyCol As Long, i As Long
Set sh = Worksheets("Destination") 'a sheet named "Destination" must exist in the workbook to be processed
sh.cells.ClearContents 'clear its content (for cases when code run before)
'some optimization to make the code faster:
Application.DisplayAlerts = False: Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'iterate between all existing sheets:
For Each ws In ActiveWorkbook.Worksheets
If ws.name <> "Destination" Then
lastEmptyCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column + 1
lastRow = ws.Range("D" & ws.rows.count).End(xlUp).row
If lastEmptyCol = 2 Then lastEmptyCol = 1 'for the first sheet
ws.Range("D1", ws.Range("K" & lastRow)).Copy sh.cells(1, lastEmptyCol)
End If
Next ws
Application.DisplayAlerts = True: Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

Copy and paste values only after filtering data in vba [duplicate]

I have two sheets. One has the complete data and the other is based on the filter applied on the first sheet.
Name of the data sheet : Data
Name of the filtered Sheet : Hoky
I am just taking a small portion of data for simplicity. MY objective is to copy the data from Data Sheet, based on the filter. I have a macro which somehow works but its hard-coded and is a recorded macro.
My problems are:
The number of rows is different everytime. (manual effort)
Columns are not in order.
Sub TESTTHIS()
'
' TESTTHIS Macro
'
'FILTER
Range("F2").Select
Selection.AutoFilter
ActiveSheet.Range("$B$2:$F$12").AutoFilter Field:=5, Criteria1:="hockey"
'Data Selection and Copy
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Hockey").Select
Range("E3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("D3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("D3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("C3").Select
ActiveSheet.Paste
End Sub
Best way of doing it
Below code is to copy the visible data in DBExtract sheet, and paste it into duplicateRecords sheet, with only filtered values. Range selected by me is the maximum range that can be occupied by my data. You can change it as per your need.
Sub selectVisibleRange()
Dim DbExtract, DuplicateRecords As Worksheet
Set DbExtract = ThisWorkbook.Sheets("Export Worksheet")
Set DuplicateRecords = ThisWorkbook.Sheets("DuplicateRecords")
DbExtract.Range("A1:BF9999").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Cells(1, 1).PasteSpecial
End Sub
I suggest you do it a different way.
In the following code I set as a Range the column with the sports name F and loop through each cell of it, check if it is "hockey" and if yes I insert the values in the other sheet one by one, by using Offset.
I do not think it is very complicated and even if you are just learning VBA, you should probably be able to understand every step. Please let me know if you need some clarification
Sub TestThat()
'Declare the variables
Dim DataSh As Worksheet
Dim HokySh As Worksheet
Dim SportsRange As Range
Dim rCell As Range
Dim i As Long
'Set the variables
Set DataSh = ThisWorkbook.Sheets("Data")
Set HokySh = ThisWorkbook.Sheets("Hoky")
Set SportsRange = DataSh.Range(DataSh.Cells(3, 6), DataSh.Cells(Rows.Count, 6).End(xlUp))
'I went from the cell row3/column6 (or F3) and go down until the last non empty cell
i = 2
For Each rCell In SportsRange 'loop through each cell in the range
If rCell = "hockey" Then 'check if the cell is equal to "hockey"
i = i + 1 'Row number (+1 everytime I found another "hockey")
HokySh.Cells(i, 2) = i - 2 'S No.
HokySh.Cells(i, 3) = rCell.Offset(0, -1) 'School
HokySh.Cells(i, 4) = rCell.Offset(0, -2) 'Background
HokySh.Cells(i, 5) = rCell.Offset(0, -3) 'Age
End If
Next rCell
End Sub
When i need to copy data from filtered table i use range.SpecialCells(xlCellTypeVisible).copy. Where the range is range of all data (without a filter).
Example:
Sub copy()
'source worksheet
dim ws as Worksheet
set ws = Application.Worksheets("Data")' set you source worksheet here
dim data_end_row_number as Integer
data_end_row_number = ws.Range("B3").End(XlDown).Row.Number
'enable filter
ws.Range("B2:F2").AutoFilter Field:=2, Criteria1:="hockey", VisibleDropDown:=True
ws.Range("B3:F" & data_end_row_number).SpecialCells(xlCellTypeVisible).Copy
Application.Worksheets("Hoky").Range("B3").Paste
'You have to add headers to Hoky worksheet
end sub
it needs to be .Row.count not Row.Number?
That's what I used and it works fine
Sub TransfersToCleared()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = Application.Worksheets("Export (2)") 'Data Source
LastRow = Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A2:AB" & LastRow).SpecialCells(xlCellTypeVisible).Copy

Excel VBA remove blank rows from specific range

I have an excel macro that creates a new sheet called "Compiled", copies over the contents of every sheet in the workbook from A2 onward (so the header isn't copied). This works great, except I often get tons of completely blank rows all over the place.
My objective is to have a macro to find the last row in the Compiled sheet, and delete any fully blank rows.
Here's my current script:
Sub CombineData()
' Delete unneeded sheets
Application.DisplayAlerts = False
Sheets("Instructions").Select
ActiveWindow.SelectedSheets.Delete
Sheets("TM Contacts").Select
ActiveWindow.SelectedSheets.Delete
' Add new sheet called Compiled
Sheets.Add After:=ActiveSheet
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Compiled"
Sheets("Lastname, First Name").Select
Range("Table_1[#Headers]").Select
Selection.Copy
Sheets("Compiled").Select
Range("A1").Select
ActiveSheet.Paste
Range("A2").Select
' Copy all sheet contents onto one
Dim lastRowSource As Long, lastRowDest As Long, i As Long
For i = 1 To Sheets.Count
If Not Sheets(i).Name = "Compiled" Then
lastRowSource = Sheets(i).Cells(Sheets(i).Rows.Count, "A").End(xlUp).Row
lastRowDest = Sheets("Compiled").Cells(Sheets("Compiled").Rows.Count, "A").End(xlUp).Row
With Sheets(i)
.Range(.Cells(2, "A"), .Cells(lastRowSource, "AB")).Copy Sheets("Compiled").Range(Sheets("Compiled").Cells(lastRowDest + 1, "A"), Sheets("Compiled").Cells(lastRowDest + 1 + lastRowSource, "AB"))
End With
End If
Next i
' delete blank rows
End Sub
I tried this code from an older question to delete the blank rows, which gave me an "out of range" error:
Dim myWs As Worksheet
Set myWs = ThisWorkbook.Worksheets("Compiled") 'set your sheet name
Dim lastRow As Long
lastRow = myWs.Range("A" & myWs.Rows.Count).End(xlUp).Row 'find last used row
With myWs.Range(myWs.Cells(2, "A"), myWs.Cells(lastRow, "A"))
.Value = .Value 'convert formulas to values whithin the range from with block (column A only)
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'delete rows where column A is blank
End With
The error with this code appears to be at "Dim myWs As Worksheet". This is where I get the "out of range" error. I'm trying to point to the compiled worksheet.
If I am not wrong, you want to combine data from different worksheets into one master sheet. But your code is producing lots of empty rows in the "Compiled" sheet. That's why you want to "remove blank rows from specific range".
What I understand from your code:
you want to:
delete sheets named "Instructions" and "TM Contacts"
add a new sheet "Compiled"
copy header from the table "Table_1" in sheet "<Last Name, First Name>" and paste it as header for sheet "Compiled"
copy data "A2" to "AB & last row" from all sheets to sheet "Compiled", starting from "A2"
Please check if this works:
Here I have tried to avoid .select
Option Explicit
Sub CombineData()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim lastRowDest As Long
Dim lastRowSource As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'delete sheets named "Instructions" and "TM Contacts". also delete "Compiled", if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Instructions").Delete
ActiveWorkbook.Worksheets("TM Contacts").Delete
ActiveWorkbook.Worksheets("Compiled").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'add a new sheet "Compiled"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Compiled"
'copy header from the table "Table_1" in sheet "Last Name, First name" and paste it as header for sheet "Compiled"
'from your code I assume you have a data formatted as a table, "Table_1"
ActiveWorkbook.Worksheets("Last Name, First Name").ListObjects("Table_1").HeaderRowRange.Copy
DestSh.Range("A1").PasteSpecial xlPasteValues
'copy data "A2" to "AB & last row" from all sheets to sheet "Compiled",starting from "A2"
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
With DestSh
lastRowDest = .Range("A" & .Rows.Count).End(xlUp).Row
End With
With sh
lastRowSource = .Range("A" & .Rows.Count).End(xlUp).Row
End With
'if you want to change copy range, change here
Set CopyRng = sh.Range("A2:AB" & lastRowSource)
With CopyRng
DestSh.Cells(lastRowDest + 1, "A").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Copy/Paste Loop through worksheets to consolidate

I have a workbook which has approximately 300 worksheets. I'm trying to loop through each sheet, copy a specific range, and paste it on summary sheet. I need each successive paste to be put one row below the last used row. I'm newer to loops, but I think the amount of information being copied is excessive(causing an error), and I have come to understand that the .value method is much less memory intensive.
How do I incorporate the .value method to accomplish this? Here is the code I tried to write (again, I'm new to coding,sorry).
Sub Consolidation()
Dim ws As Worksheet
Sheets("Summary").Select
For Each ws InThisWorkbook.Sheets
ActiveSheet.Range("A" & Rows.Count).End(xLUp).Offset(1).Value ="ws.Range("BB1").End(xLToRight).End(xLDown).Select"
Next ws
End Sub
Alternatively, is there a better way to do this? Meaning, is the .value method the way to tackle this issue?
This question is similar than:
Simple Copy/Paste Loop not working on each worksheet
This is the way you can use the .Value
Sub WsLoop()
Dim ws As Worksheet
Dim Summary As Worksheet
Set Summary = ThisWorkbook.Sheets("Summary")
For Each ws In ThisWorkbook.Sheets
If Not ws.Name = "Summary" Then 'This will skip Summary.
Summary.Range("A1").Value = ws.Range("A1").Value
End If
Next ws
End Sub
Sub loop_through_all_worksheets_cpyPst()
Dim ws As Worksheet
Dim starting_ws As Worksheet
Set starting_ws = Sheets("startAtSheet")
'remember which worksheet is active in the beginning
For Each ws In ThisWorkbook.Worksheets
ws.Activate
If Not ws.Name = "SheettoPasteTo_skipCopy" Then 'This will skip Summary.
Range("A2:I2").Select
'my section range had only columns till i - edit the to last column
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("SheettoPasteTo_skipcopy").Select
'edit this sheet name to copy to
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.End(xlDown).Select
End If
ws.Cells(1, 1) = 1 'this sets cell A1 of each sheet to "1"
Next
starting_ws.Activate
'activate the worksheet that was originally active
End Sub

Excel 2007, Copying rows from one sheet to another based on a value in 1 column

I'm trying to copy a range of rows where the rows chosen are based on the value in one cell.I want to do this for all rows containing the same value in a cell, then move on to the next value an append to the bottom of the first list.
Below is my attempt at explaining what I wish to achieve - hopefully the above will help explain more my dilemma. I have looked around for this but not quite found what I want. I thought it would be simple and probably is.
I receive a data dump with thousands of rows of data and 18 columns. Based on the value of column P "Contract" I want to copy entire rows into a new single worksheet workingdata. Not all the data will go into the workingdata worksheet.
The contract numbers are c1234, c1235, c2345 etc.
What i am after achieving is copying and sorting, so copy all the rows of data where contract number is c1234, in workingdata, then directly below it copy all rows where contract is c1235 and so on.
I thought I could select the range P:P and sort but to no avail.
Sheets("Data Dump").Select
Columns("P:P").Select
If Selection.Value = "C1234" Then
Selection.EntireRow.copy
I know I should post what i have tried, but it would be a pathetic, for some reason I just can't seem to get my head round this one.
Here's my latest effort - I know there are errors
Dim oWorksheet As Excel.Worksheet
Dim oRangeSource As Excel.Range
Dim oRangeDest As Excel.Range
Set oWorksheet = Worksheets("DataDump")
Set oRangeSource = oWorksheet.Range("p:p")
Set oRangeDest = Worksheets("workingdata")
If oRangeSource="CA0004000" Then Select.EntireRow
Selection.EntireRow.copy
Sheets("workingdata").Select.Paste
End If
latest effort but does not sort data or get rid of unwanted, I have to do a manual filter and sort which sorts of defeats the object of the macro
Sub copy()
'
' copy Macro
'
Dim rngContracts As Range: Set rngContracts = Sheets("DataDump").Range("P:P")
Dim wsData As Worksheet
Dim wsFound As Boolean: wsFound = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "Working Data" Then
Set wsData = ws
wsFound = True
Exit For
End If
Next ws
If wsFound = False Then
Application.CutCopyMode = False
ActiveSheet.Range("A1").EntireRow.copy
Set wsData = Sheets.Add(After:=Sheets(Sheets.Count))
wsData.Name = "Working Data"
wsData.Range("A1").EntireRow.PasteSpecial xlPasteAll, Transpose:=False
End If
Dim iCell As Range
For Each iCell In rngContracts
If iCell.EntireRow.Hidden = False Then
Application.CutCopyMode = False
iCell.EntireRow.copy
wsData.Range("P" & Rows.Count).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteAll, Transpose:=False
End If
Next iCell
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Latest attaempt - copies the data I need but does not sort:
Sub copytest()
'
' copytest Macro
'
Set MR = Sheets("data Dump").Range("P:P")
For Each cell In MR
If cell.Value = "CA000154" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000220" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000393" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000429" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
Record a macro to set filters on your data select one filter only.
Then, edit the code and loop through each filter copying the visible range on to your sheet. This must also sort your data as the filters are already sorted.
Also, take a look at creating filter arrays in the Excel VBA help with regards to using them to sort.

Resources