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
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
my code runs by copying a specific range of data from multiple sheets that are available on the workbook. But I want to skip a sheet called "Data Recap" so that the code only runs for the other sheets only
what should I add to my code?
Sub Copy_Data()
Dim ws As Worksheet, MasterSheet As Worksheet
Dim originalDestinationCell As Range, nextDestCell As Range
Dim firstGreyCell As Range, c As Range, e As Range, s As Range
Dim lastRow As Long, firstRow As Long, colToCheckLast As Long, i As Long
Dim isMain As Boolean
Set MasterSheet = Sheets("Form Rekap") 'where you want to put the copied data
Set originalDestinationCell = MasterSheet.Range("C6") 'the first cell the data will be copied to
Set nextDestCell = originalDestinationCell.Offset(-1, 0)
firstRow = 6
colToCheckLast = 7
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = MasterSheet.Name Then
Set firstGreyCell = ws.Range("C" & firstRow) 'Set first starting loop cell
lastRow = ws.Cells(ws.Rows.Count, colToCheckLast).End(xlUp).Row
isMain = True
For i = firstRow To lastRow
Set c = ws.Range("C" & i)
Set e = ws.Range("E" & i)
Set s = Nothing
If isMain Then
If c.Interior.Color = firstGreyCell.Interior.Color Then
If Not IsEmpty(c) Then
Set s = c
Else
isMain = False
End If
End If
Else
If c.Interior.Color = firstGreyCell.Interior.Color Then
If Not IsEmpty(c) Then
Set s = c
End If
isMain = True
Else
If Not IsEmpty(e) Then
Set s = e
End If
End If
End If
If Not s Is Nothing Then
Set nextDestCell = MasterSheet.Cells(nextDestCell.Row + 1, originalDestinationCell.Column)
nextDestCell.Interior.Color = s.Interior.Color
nextDestCell.Value = s.Value
End If
Next
End If
Next ws
End Sub
Few ways to do what you want:
Sub SkipSpecificWorksheet()
Dim ws As Worksheet
'Your version
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = MasterSheet.Name And Not ws.Name = "Data Recap" Then 'Add another condition
'Do stuffs to the worksheet
End If
Next ws
'Alternative
'Same logic as above, just different syntax
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> MasterSheet.Name And ws.Name <> "Data Recap" Then
'Do stuffs to the worksheet
End If
Next ws
'Another alternative using Select Statement
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case MasterSheet.Name, "Data Recap" 'List of worksheet to skip
Case Else
'Do stuffs to the worksheet
End Select
Next ws
End Sub
Process Worksheets With Exceptions
Option Explicit
Sub ProcessWorksheets()
Const ExceptionsList As String = "Form Recap,Data Recap"
Dim Exceptions() As String: Exceptions = Split(ExceptionsList, ",")
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
' e.g.:
Debug.Print ws.Name
'Else ' is in the list; do nothing
End If
Next ws
End Sub
I've been wanting to copy the value but also the format and the cell color of the last non empty cell in column B, and past it in cell B1 in all the sheets.
Here is the code I used, but I always get an error.
Sub copypaste()
Dim wb As Workbook
Dim ws As Worksheet
Dim Lastcell As String
Application.ScreenUpdating = False
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
Lastcell = ws.Cells(Rows.Count, "B").End(xlUp).Cell
Lastcell.Copy
ws.Range("B1").PasteSpecial Paste:=xlPasteFormats
ws.Range("B1").PasteSpecial Paste:=xlPasteValue
Next ws
Set wb = Nothing
End Sub
could you please help ?
Thanks in advance
Cell Copy in Multiple Worksheets
Option Explicit
Sub CopyPaste()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
Dim sCell As Range ' Source Cell Range
Dim dCell As Range ' Destination Cell Range
Application.ScreenUpdating = False
For Each ws In wb.Worksheets
' Cells...
Set dCell = ws.Cells(1, "B")
Set sCell = ws.Cells(ws.Rows.Count, "B").End(xlUp)
' ... or Range...
'Set dCell = ws.Range("B1")
'Set sCell = ws.Range("B" & ws.Rows.Count).End(xlUp)
' Fastest (if it covers what you need)
dCell.Value = sCell.Value
dCell.NumberFormat = sCell.NumberFormat
dCell.Interior.Color = sCell.Interior.Color
' Fast
' sCell.Copy dCell
' dCell.Value = sCell.Value
' Slow (the selection changes)
' sCell.Copy
' dCell.PasteSpecial xlPasteValues
' dCell.PasteSpecial xlPasteFormats
Next ws
' Only for the Slow version:
'Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
You look to be declaring Lastcell as a string but treating it as a range. Something like this would work.
Sub copypaste()
Dim wb As Workbook
Dim ws As Worksheet
Dim Lastcell As Range
Application.ScreenUpdating = False
Set wb = ThisWorkbook
For Each ws In wb.Worksheets
Set Lastcell = ws.Cells(Rows.Count, "B").End(xlUp)
Lastcell.Copy
ws.Range("B1").PasteSpecial Paste:=xlPasteValues
ws.Range("B1").PasteSpecial Paste:=xlPasteFormats
Next ws
Set wb = Nothing
End Sub
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
I want to copy all columns from "B" until the end of the sheet into a new sheet named "combined". The Header table in sheets "Combined" is the same of every sheets ("A").
Sub Combine()
' Sheets(1).Select
' Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "Combined"
' copy headings
Sheets(2).Activate
Range("A1").EntireColumn.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
Dim ws As Worksheet
Dim wsDest As Worksheet
Set wsDest = Sheets("Combined")
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> wsDest.Name Then
ws.Range("B1", ws.Range("B1").End(xlToRight).End(xlDown)).Copy
wsDest.Cells(1, Columns.Count).End(xlToLeft).Offset("B").PasteSpecial xlPasteValues
End If
Next ws
End Sub
.Offset("B") isn't a valid syntax
to shift one column to the right you want .Offset(, 1)
Dim ws As Worksheet
Dim wsDest As Worksheet
Set wsDest = Sheets("Combined")
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> wsDest.Name Then
ws.Range("B1", ws.Range("B1").End(xlToRight).End(xlDown)).Copy
wsDest.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial xlPasteValues
End If
Next ws