i have a little project in excel with VBA but i have question, how to select all worksheets with prefix and how to copy from selected worksheets tables to one new ?
Sub Svod_table()
Dim sh As Worksheet
Dim i As Ranges
For Each sh In Worksheets
If ComboBox1.Value = "Fist age" Then
If sh.name Like "1c.*" Then
With sh
.Select
End With
End If
End If
Next sh
End Sub
This will consolidate the grades into one sheet with a column for each subject.
Sub Svod_table()
Dim shNew As Worksheet
Dim sh As Worksheet
Dim rngDst As Range
Dim rngSrc As Range
For Each sh In Worksheets
'If ComboBox1.Value = "Fist age" Then
If sh.name Like "1c.*" Then
If shNew Is Nothing Then
Set shNew = Sheets.Add
Set rngDst = shNew.Range("A1")
Set rngSrc = sh.Range("A1").CurrentRegion
rngSrc.Copy rngDst
Set rngDst = rngDst.Offset(, rngSrc.Columns.Count)
Else
Set rngSrc = sh.Range("A1").CurrentRegion
Set rngSrc = rngSrc.Columns(rngSrc.Columns.Count)
rngSrc.Copy rngDst
Set rngDst = rngDst.Offset(, 1)
End If
End If
'End If
Next sh
End Sub
This code will copy the data from every sheet with a name starting with '1c.*' to a new sheet, one below the other.
It assumes each of the sheets is structured the same and have the same heading.
Sub Svod_table()
Dim shNew As Worksheet
Dim sh As Worksheet
Dim rngDst As Range
Dim rngSrc As Range
For Each sh In Worksheets
If ComboBox1.Value = "Fist age" Then
If sh.Name Like "1c.*" Then
If shNew Is Nothing Then
Set shNew = Sheets.Add
Set rngDst = shNew.Range("A1")
Set rngSrc = sh.Range("A1").CurrentRegion
Else
Set rngSrc = sh.Range("A1").CurrentRegion
Set rngSrc = rngSrc.Offset(1).Resize(rngSrc.Rows.Count - 1)
End If
rngSrc.Copy rngDst
Set rngDst = rngDst.Offset(rngSrc.Rows.Count)
End If
End If
Next sh
End Sub
Related
I have the following code which works on perfectly on my personal pc with the sample data. When I apply the same code to the real data from my work (on company pc) it only copies the headrs of the data. not sure if it helps but the excel file from work is confidential file and I see the message above the A B C D.....
Sub SheetLoop()
Dim Ws As Worksheet, wb As Workbook, DestSh As Worksheet
Dim Rng As Range, CRng As Range, DRng As Range, i As Long
Set wb = ThisWorkbook
Set DestSh = wb.Worksheets("Report")
Set CRng = DestSh.Range("L1").CurrentRegion
Set DRng = DestSh.Range("A3")
For Each Ws In wb.Worksheets
If Ws.Name <> DestSh.Name Then
i = i + 1
Set Rng = Ws.Range("A1").CurrentRegion
Rng.AdvancedFilter xlFilterCopy, CRng, DRng
If i > 1 Then DRng.Cells(1).EntireRow.Delete xlUp 'delete the first row of the copied range, except the first case
Set DRng = DestSh.Range("A" & DestSh.Rows.Count).End(xlUp).Offset(1) 'reset the range where copying to
End If
Next Ws
MsgBox "Ready..."
End Sub
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.
The code works. It loops through my worksheets in my workbook and excludes the ones listed in the IF statement below.
I am trying to not hard code each sheet name I want to exclude.
I want to create a separate sheet where I enter the sheet names to exclude in the range A1:10 so the IF statement can nab the sheet names.
Dim Ws As Worksheet
For Each Ws In Worksheets
If Ws.Name <> "MainMenu" And Ws.Name <> "All in One View" And Ws.Name <> "Complete" _
And Ws.Name <> "LDD on Hold" And Ws.Name <> "LDD Projects in Queue" And Ws.Name <> "ON HOLD" _
And Ws.Name <> "Blank" And Ws.Name <> "Project Assignments" Then
Set rngData = Ws.UsedRange
rngData.Offset(5, 1).Resize(rngData.Rows.Count - 5, rngData.Columns.Count - 3).Copy Sheet26.Range(ActiveCell.Address)
Range("C6").End(xlDown).Select
ActiveCell.Offset(1, 0).Select
End If
Next Ws
Something like this should work for you. Make sure the name of your destination worksheet, and the name of your exclusion worksheet (I named it ExcludeSheets) are included in the list.
Sub tgr()
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim wsDest As Worksheet: Set wsDest = wb.Worksheets(26)
Dim wsExcl As Worksheet: Set wsExcl = wb.Worksheets("ExcludeSheets")
Dim rExclude As Range: Set rExclude = wsExcl.Range("A1", wsExcl.Cells(wsExcl.Rows.Count, "A").End(xlUp))
Dim aExclude() As Variant
If rExclude.Cells.Count = 1 Then
ReDim aExclude(1 To 1, 1 To 1)
aExclude(1, 1) = rExclude.Value
Else
aExclude = rExclude.Value
End If
Dim ws As Worksheet, rCopy As Range, rDest As Range
For Each ws In wb.Worksheets
Select Case IsError(Application.Match(ws.Name, aExclude, 0))
Case False 'do nothing, worksheet found to be in exclude list
Case Else
Set rCopy = ws.UsedRange.Offset(5, 1).Resize(ws.UsedRange.Rows.Count - 5, ws.UsedRange.Columns.Count - 3)
Set rDest = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1)
rCopy.Copy rDest
End Select
Next ws
End Sub
Using Match() against a list of excluded sheets:
Dim Ws As Worksheet, rngExcl As Range
Set rngExcl = ThisWorkbook.Worksheets("list").Range("A1:A10")
For Each Ws In Worksheets
If IsError(Application.Match(Ws.Name, rngExcl, 0) Then
Set rngData = Ws.UsedRange
With rngData
.Offset(5, 1).Resize(.Rows.Count - 5, .Columns.Count - 3).Copy _
Sheet26.Range("C6").End(xlDown).Offset(1, 0)
End With
End If
Next Ws
So, I have one excel workbook containing around 80 sheets, the sheets are named as Input, Input(1), input, INPUT, INPUT(2) and Output, Output(1), Output(2), output, OUTPUT and so on, you get the idea... I want to create a macro which creates two mastersheets in the Workbook named "MASTERSHEET INPUT" and "MASTERSHEET Output". The macro should copy all the data from any sheet having any variation of input in its sheet name and paste it one into the MASTERSHEET INPUT and the same goes for the sheets named output which will be pasted into MASTERSHEET OUTPUT. I'm relatively new to VBA and I'd really appreciate it if someone could help me out.
Thanks in advance!
This is the code I was using previously
Sub CombineData()
Dim I As Long
Dim xRg As Range
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet"
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
But this merges all the sheets in the workbook into one without checking the sheet name.
I tried using this one next but this just pastes the first Output sheet into both mastersheets and then ends:
Sub CombineData()
Dim I As Long
Dim xRg As Range
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet Output"
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
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name = "OUTPUT*" Or xWs.Name = "output*" Or xWs.Name = "Output*" Then
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
End If
Next
Next
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet Input"
For I = 3 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name = "INPUT*" Or xWs.Name = "input*" Or xWs.Name = "Input*" Then
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
End If
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Call DeleteAllSheetsExceptMaster
End Sub
I also tried using this but this does absolutely nothing:
Sub CombineData()
Dim I As Long
Dim xrg As Range
Dim counter As Long
Dim xWs1 As Worksheet
Dim xWs2 As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For counter = 1 To 2
Worksheets.Add Sheets(1)
If counter = 1 Then
ActiveSheet.Name = "MasterSheet Input"
Set xWs1 = ActiveSheet
End If
If counter = 2 Then
ActiveSheet.Name = "MasterSheet Output"
Set xWs2 = ActiveSheet
End If
Next counter
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
If Sheets(I).Name = "OUTPUT*" Or Sheets(I).Name = "output*" Or Sheets(I).Name = "Output*" Then
ActiveSheet.UsedRange.Copy xWs2
End If
If Sheets(I).Name = "INPUT*" Or Sheets(I).Name = "input*" Or Sheets(I).Name = "Input*" Then
ActiveSheet.UsedRange.Copy xWs1
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Create Master Sheets
The following will delete each of the master worksheets if they exist and then create new ones. Then it will copy the data from the current region starting in A1 of the defined source worksheets to the appropriate master worksheets (read OP's requirements).
The Code
Option Explicit
Sub createMasterSheets()
' Define constants incl. the Names Arrays and the workbook.
Const srcFirst As String = "A1"
Const tgtFirst As String = "A1"
Dim srcNames As Variant
srcNames = Array("iNpUt", "oUtPuT") ' Case does not matter.
Dim tgtNames As Variant
tgtNames = Array("MasterIn", "MasterOut")
Dim wb As Workbook
Set wb = ThisWorkbook
' Define lower and upper subscripts of the 1D arrays:
' srcNames, tgtNames, Dicts
Dim sFirst As Long
sFirst = LBound(srcNames)
Dim sLast As Long
sLast = UBound(srcNames)
' Turn off screen updating.
Application.ScreenUpdating = False
' Add Target Worksheets.
Dim ws As Worksheet
Dim n As Long
For n = sLast To sFirst Step -1
On Error Resume Next
Set ws = wb.Sheets(tgtNames(n))
On Error GoTo 0
If Not ws Is Nothing Then
Application.DisplayAlerts = False
wb.Sheets(tgtNames(n)).Delete
Application.DisplayAlerts = True
End If
wb.Worksheets.Add Before:=wb.Sheets(1)
ActiveSheet.Name = tgtNames(n)
Next n
' Define Dictionaries Array and populate it with Dictionaries.
' The Dictionaries will hold the Data Arrays.
Dim Dicts As Variant
ReDim Dicts(sFirst To sLast)
Dim dict As Object
For n = sFirst To sLast
Set dict = CreateObject("Scripting.Dictionary")
Set Dicts(n) = dict
Next n
' Declare variables.
Dim wsName As String ' Current Worksheet Name
Dim rng As Range ' Current Source Range, Current Target Cell Range
Dim m As Long ' Subscript of Current Data Array in Current Dictionary
' of Dictionaries Array
' Write values from Source Ranges to Data Arrays.
For Each ws In wb.Worksheets
wsName = ws.Name
For n = sFirst To sLast
If InStr(1, wsName, srcNames(n), vbTextCompare) = 1 Then
' Define Source Range. You might need to do this in another way.
Set rng = ws.Range(srcFirst).CurrentRegion
m = m + 1
Dicts(n)(m) = rng.Value ' This will fail later if one cell only.
Exit For
End If
Next n
Next ws
' Declare variables
Dim Key As Variant ' Current Key in Current Dictionary
' of Dictionaries Array.
' Write values from Data Arrays to Target Ranges.
For n = sFirst To sLast
Set rng = wb.Worksheets(tgtNames(n)).Range(tgtFirst)
Set ws = wb.Worksheets(tgtNames(n))
For Each Key In Dicts(n).Keys
rng.Resize(UBound(Dicts(n)(Key), 1), _
UBound(Dicts(n)(Key), 2)).Value = Dicts(n)(Key)
Set rng = rng.Offset(UBound(Dicts(n)(Key), 1))
Next Key
Next n
' Turn on screen updating.
Application.ScreenUpdating = True
' Inform user.
MsgBox "Sheets created, data transferred.", vbInformation, "Success"
End Sub
See if this works for you.
Edit: fixed case sensitivity.
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 'Input Master
Dim trg2 As Worksheet 'Output Master
Dim rng As Range 'Range object
Set wrk = ActiveWorkbook 'Working in active workbook
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Input Master"
'Add new worksheet as the last worksheet
Set trg2 = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg2.Name = "Output Master"
'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 - 1 Then
Exit For
ElseIf LCase(sht.Name) Like "*" & "input" & "*" Then
Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(65536, 1).End(xlUp))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
ElseIf LCase(sht.Name) Like "*" & "output" & "*" Then
Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(65536, 1).End(xlUp))
'Put data into the Master worksheet
trg2.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
trg.Rows(1).Delete
trg.Columns.AutoFit
trg2.Rows(1).Delete
End Sub
I'm trying to copy and paste a certain value from a cell in one sheet matching a range in another workbook. The code runs fine, doesn't give any run-time errors, but will not paste in the range declared in the other workbook. Code below
Sub ConditionalCopy()
Dim dest As Worksheet
Set dest = ActiveWorkbook.Worksheets("VCP Plan")
Dim rng As Range, cell As Range
Set rng = Range("D:D")
Dim OpenWorkBook As Variant
OpenWorkBook = Application.GetOpenFilename("Excel Files (*.xlsx* (*.xlsx*),")
If OpenWorkBook <> False Then
Workbooks.Open (OpenWorkBook)
End If
For Each cell In rng
If cell.Value = "26ASA00015D007" Then
cell.Offset(0, 3).Copy Destination:=dest.Range("E3")
End If
Next cell
End Sub
It is unclear from your description and your code which workbook/worksheet you want to compare and copy, and which workbook/worksheet you want to copy to.
You'll need to be more specific
I've made a guess at what you are trying to do. If I've got it wrong, simply adjust the references to suit
Something like
Sub ConditionalCopy()
Dim wbSource as Workbook
Dim wsSource as Worksheet
Dim rSource as Range
Dim wbDest as Workbook
Dim wsDest as Worksheet
Dim rDest as Range
Set wbDest = ActiveWorkbook ' Are you sure?
Set wsDest = wbDest.Worksheets("VCP Plan")
Set rDest = ws.Range("E3")
Dim OpenWorkBook As Variant
OpenWorkBook = Application.GetOpenFilename("Excel Files (*.xlsx* (*.xlsx*),")
If OpenWorkBook <> False Then
Set wbSource = Workbooks.Open(OpenWorkBook)
Else
Exit Sub
End If
Set wsSource = wbSource.Worksheets("NameOfSourceSheet")
Dim cell As Range
With wsSource
' Column D from row 1 to last used row
Set rSource = .Range(.Cells(1, 4), .Cells(.Rows.Count, 4).End(xlUp))
End With
For Each cell In rSource
If cell.Value = "26ASA00015D007" Then
cell.Offset(0, 3).Copy Destination:=rDest
' You probably don't want to overwrite each time, so
Set rDest = rDest.Offset(1, 0)
End If
Next cell
End Sub