I have a workbook with about 80 sheets. Each sheet is in the same format (there are some blanks here and there).
Is there a way to transpose the same row e.g. A2 - K2 from all 80 sheets into columns in a summary sheet?
This post (Transpose data from a specific column from multiple sheets to rows on another 'summary' sheet) transposes columns to rows.
Try this. It assume that all your data sheets are named as number.
It will ad a new sheet "Summary". If the sheet "Summary" exist, it will delete it.
Sub MakeSummary()
Dim v As Variant
Dim wsSummary As Worksheet
'Assume that there are worksheets with data in range A2:A12
'All this sheets are named by number (1, 2, ... n)
'There will be a new Summary sheet created with the transposed range
'Add the new Worksheet
Set wsSummary = ThisWorkbook.Worksheets.Add
On Error Resume Next
wsSummary.Name = "Summary" 'Try to name it "Summary"
If wsSummary.Name <> "Summary" Then
'If the name is not "Summary" than failed, probably there is already a sheet named as "Summary"
Worksheets("Summary").Delete 'Delete the sheet "Summary"
End If
wsSummary.Name = "Summary" 'Try again name the sheet to "Summary"
On Error GoTo 0
Dim rngTarget As Range
Dim rngSource As Range
Set rngTarget = wsSummary.Range("A2:A12") 'size should match
Dim i As Long
For Each v In ThisWorkbook.Worksheets 'Looping through all the worksheets
If IsNumeric((v.Name)) Then 'If the name is number, then it is a data sheet
i = i + 1
Set rngSource = v.Range("A2:K2") ' Set the source range to the actual sheet and range
rngTarget.Offset(, i).Value = Application.WorksheetFunction.Transpose(rngSource.Value)
End If
Next v
End Sub
Related
i am very new to vba , currently i am looking for code to copy cell values from list to multiple sheet in specific cell
what i am trying to do is as per bellow sheet "point" i have a list with values column B are the names and C & D are values
i need to copy sheet named "template" and rename as per the values in Column B and the values are un defined and be upto any length
list sheet
template
currently i am using bellow code to copy sheet and rename as per list
Sub CopySheetRenameFromCell()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Set sh1 = Sheets("template")
Set sh2 = Sheets("point")
For Each c In sh2.Range("B6", sh2.Cells(Rows.Count, 2).End(xlUp))
sh1.Copy After:=Sheets(Sheets.Count)
On Error Resume Next
ActiveSheet.Name = c.Value:
On Error GoTo 0
Next
End Sub
result sheet
but i have no idea how can i copy value from "point" Sheet Column C and D values 1 & 51 to sheet "a" Column C2 and F2 and so on
a values in sheet "a"
b values in sheet "b" and on
awaiting your help
Copy Template Worksheet
This is a basic code. It assumes that each of the cells of the range B6:BLastRow contains a valid value for naming a worksheet. It also assumes that each of the worksheets to be created does not exist already.
Option Explicit
Sub CopySheetRenameFromCell()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets("Point")
' Calculate the source last row ('slRow'),
' the row of the last non-empty cell in the column.
Dim slRow As Long
slRow = sws.Cells(sws.Rows.Count, "B").End(xlUp).Row
' Reference the template worksheets ('tws').
Dim tws As Worksheet: Set tws = wb.Worksheets("Template")
' Declare additional variables.
Dim dws As Worksheet ' Current Destination (Copied) Worksheet
Dim sr As Long ' Current Row in the Source Worksheet
' Loop through the rows of the source worksheet.
For sr = 6 To slRow
' Create a copy of the template worksheet after the last sheet
' in the workbook.
tws.Copy After:=wb.Sheets(wb.Sheets.Count)
' Reference this copy, the destination worksheet,
' which is the last (work)sheet in the workbook.
Set dws = wb.Sheets(wb.Sheets.Count)
' Rename the destination worksheet.
dws.Name = sws.Cells(sr, "B").Value
' Write the values from columns 'C' and 'D' in the row ('r')
' of the source worksheet to the cells `C2` and `F2` respectively
' in the destination worksheet.
dws.Range("C2").Value = sws.Cells(sr, "C").Value
dws.Range("F2").Value = sws.Cells(sr, "D").Value
Next sr
' Save the workbook.
'wb.Save
' Inform.
MsgBox "Point worksheets created.", vbInformation
End Sub
Currently I have a lot of sheets in my Excel file but I want to get the last row of data in sheets that start with "6" as their names as the other sheets are not relevant. In the sheets that start with 6 are all in the same format but have different number of rows, I am interested in extracting the last row in all those sheets (columns D:J) and placing it into a "master sheet". Since I am quite new to VBA, how would I go about doing that? Thanks in advance!
What I have currently that can copy one sheet and paste into my master sheet "Sheet2":
With Sheets("6363")
With Range(.Cells(.Rows.Count, "D").End(xlUp), _
.Cells(.Cells(.Rows.Count, "D").End(xlUp).row, .Columns.Count).End(xlToLeft))
Worksheets("Sheet2").Range("D1").Resize(, .Columns.Count).Value = .Value
End With
End With
This will copy the last row, columns D-J, from every sheet with a name that starts with '6'.
It will put the copied data into the next empty row, starting at column D, of 'Sheet2'.
Sub CopySix()
Dim wsSrc As Worksheet
Dim wsDst As Worksheet
Dim rngSrc As Range
Dim rngDst As Range
Set wsDst = ActiveWorkbook.Sheets("Sheet2")
Set rngDst = wsDst.Range("D" & Rows.Count).End(xlUp).Offset(1)
For Each wsSrc In ActiveWorkbook.Sheets
If Left(wsSrc.Name, 1) = "6" Then
Set rngSrc = wsSrc.Range("D" & Rows.Count).End(xlUp).Resize(, 7)
rngDst.Resize(, 7).Value = rngSrc.Value
Set rngDst = rngDst.Offset(1)
End If
Next wsSrc
End Sub
I'm new to VBA Excel and I have some code that will go through multiple sheets and copy values in certain range of cells if the criteria are met.
So basically I would like to copy certain data from multiple sheets and paste it in certain cells (it must be placed based on the variable in the cells)
I would like to copy from sheet 1, 2, 3, etc., cell E to L and place it in another sheet, based on the value of cell L5:
And paste it to this sheet, in cell F to M, if the value of cell C in sheet Template 1 are the same with cell L5 in sheet 1,2,3,etc:
Here are the code that I have:
Option Explicit
'Note: This example use the function LastRow
'This example copy the range A2:G2 from each worksheet.
'
'Change the range here
'
''Fill in the range that you want to copy
'Set CopyRng = sh.Range("A2:G2")
'When you run one of the examples it will first delete the summary worksheet
'named RDBMergeSheet if it exists and then adds a new one to the workbook.
'This ensures that the data is always up to date after you run the code.
'*****READ THE TIPS on the website****
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
Dim i As Integer
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
'Application.DisplayAlerts = False
'On Error Resume Next
'ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
'On Error GoTo 0
'Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets("Template 1")
'DestSh.Name = "RDBMergeSheet"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
'Loop through all worksheets except the RDBMerge worksheet and the
'Information worksheet, you can ad more sheets to the array if you want.
If IsError(Application.Match(sh.Name, _
Array("Information", "Template 1", "Template 2", "Template 3"), 0)) Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng = sh.Range("E10:L10")
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this macro
'For i = 2 To LastRow(DestSh)
CopyRng.Copy
With DestSh.Cells(Last + 1, "E")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This 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 DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
The code above succeeded to copy from sheet 1,2,3,etc in cell range but place it in the last row and not yet based on the criteria.
I would like to know how to incorporate the criteria that I need to the code above? Thanks
This code will do for loops which find the sheet where the L5 value matches the C1 value in each of the Templates. Inside that if statement is where you can put the code you have that copies and pastes the values. Good luck!
Sub matchTemplateWithSheet()
'
' matchTemplateWithSheet Macro
'
'
Dim x As Integer
Dim y As Integer
Dim a As Integer
Dim b As Integer
Dim numberOfTemplates As Integer
Dim numberOfSheets As Integer
numberOfTemplates = 3 'you can set the number of templates you're trying to fill
numberOfSheets = 5 ' you can set the number of sheets you're looking through. _
this can also easily be automated in the code
For x = 1 To numberOfTemplates
a = ActiveWorkbook.Worksheets("Template " & x).Cells(1, 3)
For y = 1 To numberOfSheets
b = ActiveWorkbook.Worksheets("Sheet" & y).Cells(5, 12)
If a = b Then
'''''This is where you can put the copy/paste code that you already have'''''
End If
Next y
Next x
End Sub
Hi I'm looking to create code for copying certain columns (AH to AX) across all worksheets then skipping worksheets named "Aggregated" & "Collated Results"
I have this already
Sub FillSheets()
Dim ws As Worksheets
Dim worksheetsToSkip As Variant
Dim rng As Range
Dim sh As Sheet1
Set rng = sh.Range("AH1:AX7200")
worksheetsToSkip = Array("Aggregated", "Collated Results")
For Each ws In Worksheets
If IsError(Application.Match(ws.Name, worksheetsToSkip, 0)) Then
End Sub
This will
Loop through sheets
"Copy" data from AH1 - AX1 down to the last used row that is determined by Column AH (Update column if needed)
"Paste" data on a sheet named Sheet1 (Update if needed). The data will be pasted in Column AH on the first available blank row. It's not clear what column you want to paste the data in. You just need to change AH to Some Column to modify
"Copy" and "Paste" are in quotes because we are really just transferring values here since this is quicker. We are actually setting the values of two equal sized ranges equal to each other.
Option Explicit
Sub AH_AX()
'Update "Sheet1" to sheet where data is being pasted
Dim ms As Worksheet: Set ms = ThisWorkbook.Sheets("Sheet1")
Dim ws As Worksheet, wsLR As Long, msLR As Long
Dim CopyRange As Range, PasteRange As Range
For Each ws In Worksheets
If ws.Name <> "Aggregated" And ws.Name <> "Collated Results" Then
'Determine last rows
wsLR = ws.Range("AH" & ws.Rows.Count).End(xlUp).Row
msLR = ms.Range("AH" & ms.Rows.Count).End(xlUp).Offset(1).Row
'Set Ranges
Set CopyRange = ws.Range("AH1:AX" & LR)
Set PasteRange = ms.Range("AH" & msLR).Resize(CopyRange.Rows.Count, CopyRange.Columns.Count)
'Value Transfer (Quicker than copy/paste)
PasteRange.Value = CopyRange.Value
End If
Next ws
End Sub
I have this list of products, and i want to:
Create new sheets based on the values on column C, if there's already a sheet with the same name as the cell value don't create a new sheet. (like "Abstract" in my example that already been created for row 2 and doesn't need to created again for row 3)
Cut the entire row to the matching sheet.
Make sure the first row is copied to all sheets.
This is a before picture
After Pic #1: new sheets created, nothing left on first sheet except the 1st row
After Pic #2: the sheet contains 2 products because there were 2 "Abstract" in column C
After Pic #3: the sheet contain 1 product because there was 1 "Plain" in column C
After Pic #4: the sheet contain 1 product because there was 1 "Shiny" in column C
This will get the job done.
I Named the first sheet to "Worksheet".
The code is dynamic, so you need to input 2 values by yourself:
Which range/names that should create the new worksheets:
Set myrange = ThisWorkbook.Sheets("Worksheet").Range("C2:C5") 'Set range that should create the new worksheet list
and how many columns you want to copy to the new sheets (it makes it more dynamic than take the whole row)
lastcol = Cells(1, "C").Column 'Set how many column that should be copied to new worksheet
VBA Code:
Sub AddNewSheetFromRange2()
Dim c As Range
Dim ws As Worksheet
Dim myrange As Range
Dim lastcol As Integer
Dim lrow As Integer
Dim lrow_newsheet As Integer
Dim i As Integer
Set myrange = ThisWorkbook.Sheets("Worksheet").Range("C2:C5") 'Set range that should create the new worksheet list
lastcol = Cells(1, "C").Column 'Set how many column that should be copied to new worksheet
lrow = Cells(Rows.Count, 3).End(xlUp).Row 'find last row for range that should create the new worksheet list
i = 1 'Set first index loop to 1
For Each c In myrange.Cells
i = i + 1 'Create index for each loop, used to know which row that should be copied
'Debug.Print c 'Print which Sheet Name that will be examine
Set ws = Nothing
On Error Resume Next
Set ws = Worksheets(c.Value)
On Error GoTo 0
If ws Is Nothing Then
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 'Add new sheet after (not before)
ws.Name = c.Value 'Rename the new sheet
End With
Dim WorksheetSheet As Worksheet 'Declare variable for Main worksheet
Set WorksheetSheet = ActiveWorkbook.Worksheets("Worksheet") 'Name the Main sheet
Dim NewSheet As Worksheet 'Declare variable for new worksheet
Set NewSheet = ActiveWorkbook.Worksheets(ws.Name) 'Make all new worksheets dynamic by taking name from range
'Copy Headers from Main sheet to New Worksheet
Worksheets("Worksheet").Activate
ThisWorkbook.Worksheets("Worksheet").Range(Cells(1, 1), Cells(1, 3)).Copy
Worksheets(ws.Name).Activate
ThisWorkbook.Worksheets(ws.Name).Range(Cells(1, 1), Cells(1, 3)).PasteSpecial
'Copy row from Main sheet to New Worksheet
Worksheets("Worksheet").Activate
ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Copy
Worksheets(ws.Name).Activate
lrow_newsheet = Cells(Rows.Count, 3).End(xlUp).Row + 1
ThisWorkbook.Worksheets(ws.Name).Range(Cells(lrow_newsheet, 1), Cells(lrow_newsheet, lastcol)).PasteSpecial
'Clear row in Main sheet
Worksheets("Worksheet").Activate
ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Clear
Else
'If worksheet already exists, then
'Copy row from Main sheet to existing worksheet with exactly the same name
Worksheets("Worksheet").Activate
ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Copy
Worksheets(ws.Name).Activate
lrow_newsheet = Cells(Rows.Count, 3).End(xlUp).Row + 1
ThisWorkbook.Worksheets(ws.Name).Range(Cells(lrow_newsheet, 1), Cells(lrow_newsheet, lastcol)).PasteSpecial
'Clear row in Main sheet
Worksheets("Worksheet").Activate
ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Clear
End If
Next c
End Sub
Visualizing the code in excel you will have to start with this:
and the final output will be this (the four rows into individual worksheets, if the name already exists, it will add to the already existing worksheet)