I need to create a summary page that will report ONLY tabs that contain conditional formatting that's true. So Tab1 contains a comparison of Before and After; the After will highlight any cells that are different than the Before; then the macro loops to do this with a new tab for every .jbi file in a folder. So each .jbi will have a copy of Tab1 named differently. I'm not sure which method would be better to identify tabs with highlighted changes on a summary page nor really how to go about searching each tab for them.
So my questions are - Should I 1.) make it part of the .jbi import loop where it creates a new copy of Tab1, pastes the before and after data, then resets the template 2.) have it look for changes once it has completed creating new tabs?
3.) How do I get it to search for true conditional formats either way?
Edit: Using the suggestion in the first comment, this is what I came up with, but it doesn't work. It never copies the values
Sub Create_summary()
Dim inputarea As Range
Set inputarea = Sheets("PGM Copy Template").Range("AF2:BA1000")
If inputarea.DisplayFormat.Interior.ColorIndex = 49407 Then
Sheets("Change Summary").Select
Rows("3:3").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
If Sheets("PGM Copy Template").Range("F4").Value = "#N/A" Then
Sheets("Change Summary").Range("B3").Text = Sheets("PGM Copy Template").Range("AI5").Text
Sheets("Change Summary").Range("C3").Text = Sheets("PGM Copy Template").Range("AI4").Text
Else
Sheets("Change Summary").Range("B3").Text = Sheets("PGM Copy Template").Range("F5").Text
Sheets("Change Summary").Range("B3").Text = Sheets("PGM Copy Template").Range("F4").Text
End If
Else
Exit Sub
End If
End Sub
I guess I need help understanding how I can make the If/then function with the search.
A bit easier to split out the check for the CF color:
Sub Create_summary()
Const CHECK_COLOR As Long = 49407 'use Const for fixed values
Dim inputarea As Range, wb As Workbook, wsInput As Worksheet, c As Range
Dim wsSummary As Worksheet, isNA As Boolean
Set wb = ThisWorkbook 'ActiveWorkbook? 'use a workbook variable
Set wsInput = wb.Worksheets("PGM Copy Template") 'use worksheet variables
Set wsSummary = wb.Worksheets("Change Summary")
If HasCfColor(wsInput.Range("AF2:BA1000"), CHECK_COLOR) Then
isNA = wsInput.Range("F4").Value = "#N/A"
With Sheets("Change Summary")
.Rows(3).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Range("B3").Text = wsInput.Range(IIf(isNA, "AI5", "F5")).Text
.Range("C3").Text = wsInput.Range(IIf(isNA, "AI4", "F4")).Text
End With
End If
End Sub
'Does range `rngToCheck` contain a cell with CF coloring of `cfColor` ?
Function HasCfColor(rngToCheck As Range, cfColor As Long)
Dim rng As Range, c As Range
On Error Resume Next 'ignore error if no CF in this range
Set rng = rngToCheck.SpecialCells(xlCellTypeAllFormatConditions) 'only cells with CF
On Error GoTo 0 'stop ignoring errors
If Not rng Is Nothing Then 'True if have any cells with CF
For Each c In rng.Cells
If c.DisplayFormat.Interior.Color = cfColor Then
HasCfColor = True
Exit Function 'done checking
End If
Next c
End If
HasCfColor = False
End Function
Related
I want to create a command button which copies a range of cells and pastes them into the next empty range.
I have found a code online which I tweaked to perform the function, but it does not work when I add conditional formatting.
The conditional formating being, blank cells = yellow.
The VBA im currently using is:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Sheet1")
copySheet.Range("B11:J11").Copy
pasteSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
If I enter a value into the blank cell the above VBA works fine, however if I leave the cell blank it does not paste into the next cell.
The aim was for the user to paste in as many rows as needed, and the yellow shading to indicate which cells to add a value in.
I hope this makes sense. I'm not particularly used to these functions in excel.
Try this code:
Private Sub CommandButton1_Click()
'Macro to copy in a new row.
'Turning off screen updating.
Application.ScreenUpdating = False
'Declarations.
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim targetRange As Range
'Setting variables.
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Sheet1")
'Setting targetRange as the last cell in column B with value.
Set targetRange = pasteSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
'Setting targetRange as the first cell in column B with no conditional formatting under the last cell in column B with no value.
Do Until targetRange.FormatConditions.Count = 0
Set targetRange = targetRange.Offset(1, 0)
Loop
'Copying range B11:J11.
copySheet.Range("B11:J11").Copy
'Pasting the copied range in targetRange.
targetRange.PasteSpecial xlPasteAll
'Turning off the cut-copy mode.
Application.CutCopyMode = False
'Turning on the screen updating.
Application.ScreenUpdating = True
End Sub
I've taken your code and added the variable targetRange. Said variable is then set as the last cell with value in column B (similar to what you have already done) and then i use a Do Loop cycle to set targetRange as the first cell with no conditional formatting under the last cell with value in column B. I've also added the proper comments to the whole code.
Extra code as requested in comments.
You can obtain a sum of the values of a range while counting any "outgoing" value as a 7 with this formula:
=SUM(B11:B15,COUNTIF(B11:B15,"ongoing")*7)
You can use the same formula in a macro like this:
Sub Macro1()
'A example of macro to return a range sum with any "ongoing" switched with 7.
'Declaration.
Dim rng As Range
'Setting the seed range.
Set rng = Range("B11")
'Expanding rng to the last cell with value of its column.
Set rng = Range(rng, Cells(Rows.Count, rng.Column).End(xlUp))
'Reporting in the immediate window the result.
Debug.Print Excel.WorksheetFunction.Sum(rng, Excel.WorksheetFunction.CountIf(rng, "ongoing") * 7)
'Reporting in the immediate window the result, this time using a With End With statement to make it more readable.
With Excel.WorksheetFunction
Debug.Print .Sum(rng, .CountIf(rng, "ongoing") * 7)
End With
End Sub
I have been trying to Copy the Filtered data and pasting the data on filtered cell but my code is not working.
I have data in Range Sheet2.Range("O2:O10000") and i filtered this range to Sheet2.Range("O173:O2400").
I want to copy the data from filtered cells Sheet2.Range("O173:O2400") then paste this data to visible cells on same Sheet2.Range("N173:N2400")
Please note there are multiple hidden rows in this range.
Any help will be appreciated
Sub Copy_Paste__Visible_Cells_Only()
Sheet2.Range("O173:O2400").SpecialCells(xlCellTypeVisible).Copy
Sheet2.Range("N173:N2400").SpecialCells(xlCellTypeVisible).Paste
End Sub
In this case, pasting won't work. As far as I know, you can't change the paste behaviour to only paste to visible cells.
When you select visible cells only, you get a collection of areas (you can think of them as a discontinuous set of ranges). Given you're just trying to move your visible data to the left, you can do it by looping through the areas and assigning their values to the same area in the previous column. Something like this:
Public Sub CopyVisible()
Dim a As Range
For Each a In Sheet1.Range("O4:O17").SpecialCells(xlCellTypeVisible).Areas
a.Offset(0, -1).Value = a.Value
Next
End Sub
The .Offset(0,-1) is signalling that you wish the values to be moved one column to the left
You can see from this example, when I filter on "a" in column O and run the macro, only the "a" values are moved to column N.
I would use a generic sub copyVisibleCellsToOtherColumn to which you pass the source-range and the target-start range.
Advantage you can re-use it for different scenarios.
Sub test_CopyVisibleCells()
Dim rgSource As Range
Set rgSource = sheet2.Range("O173:O2400")
Dim rgTarget As Range
Set rgTarget = sheet2.Range("N173:02400")
copyVisibleCells rgSource, rgTarget
End Sub
'this ist the generic sub
Public Sub copyVisibleCellsToOtherColumn(rgSource As Range, rgTarget As Range)
Dim c As Range, a As Range
For Each a In rgSource.Areas
'this will return the visible cells within rgsource
For Each c In a.Cells
rgTarget.Rows(c.Row).Value = c.Value
Next
Next
End Sub
I found code from somewhere which able to copy visible cells and paste into visible cells. For easy usage, I manually assign a shortcut ctrl+shift+C to call the macro.
Public Sub Copy_Range_Paste_Into_Visible_Cells()
'Sub Copy_Range_Paste_Into_Visible_Cells()
Dim rngSource As Range, rngDestination As Range, cell As Range, cc As Long, i As Long
On Error Resume Next
Application.DisplayAlerts = False
Set rngSource = Application.InputBox("Select the filtered range to copy. ", "Select Filtered Cells", Type:=8)
If rngSource Is Nothing Then Application.DisplayAlerts = True: Exit Sub 'User canceled
Set rngDestination = Application.InputBox("Select the destination cell to paste to. ", "Select Paste Destination", Type:=8)
If rngDestination Is Nothing Then Application.DisplayAlerts = True: Exit Sub 'User canceled
On Error GoTo 0
Application.DisplayAlerts = True
cc = rngSource.Columns.Count
For Each cell In rngSource.Columns(1).SpecialCells(xlCellTypeVisible)
Do Until Not rngDestination(1).Offset(i).EntireRow.Hidden
i = i + 1
Loop
rngDestination(1).Offset(i).Resize(1, cc).Value = cell.Resize(1, cc).Value
i = i + 1
Next
End Sub
I am trying to copy a specific range from a protected sheet that has an autofilter with a few rows in the range filtered out.
When using the following code, only the visible rows in the range get copied:
origWB.Sheets("some data").Range("D3:LB77").Copy
targetWS.Cells(3, 4).PasteSpecial xlValues
As I said, the sheet is protected (and for various reasons I can't unprotect it within the macro), so I can't use commands that would normally solve the problem like this:
origWB.Sheets("some data").Range("D3:LB77").EntireRow.Hidden = False
I've been able to cancel the filter:
origWB.Sheets("some data").AutoFilterMode = False
This enables me to copy all the lines but then I can't figure out how to get the filter working again (as I need to leave the sheet exactly the way I found it) without getting blocked by the sheet protection.
I would appreciate either a solution that temporarily removes the filter and resumes it after the copy, or a solution that enables me to copy all the range including the hidden/filtered rows without messing with the filter itself.
The following code adds a new worksheet and copies the entire range to the new spreadsheet where you can then copy and paste where you like
I have directed the copy to be below the existing filtered data but this can be redirected
Sub CopyFilteredData()
Dim wsDst As Worksheet, tblDst As Range
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsSrc As Worksheet: Set wsSrc = wb.Worksheets("some data")
Dim tblSrc As Range: Set tblSrc = wsSrc.Range("D3:LB77")
Set wsDst = wb.Worksheets.Add
Set tblDst = wsDst.Range(tblSrc.Address)
tblDst = "='" & wsSrc.Name & "'!" & tblSrc.Address
tblDst.Copy
tblSrc.Offset(tblSrc.Rows.Count + 1, 0).PasteSpecial xlPasteValues
Application.DisplayAlerts = False
wsDst.Delete
Application.DisplayAlerts = True
End Sub
I am not sure if it is possible to copy invisible cells by "copy". As far as i know it is not possible.
However, it is possible to read each cell value / styling properties cell by cell.
It should do the work fine for smaller ranges, but it is really slow when we have more cells (it trying to read each value instead copying entire range and this is time consuming).
Option Explicit
Sub code()
'a little performence boost
Application.ScreenUpdating = False
Dim source_cols As Integer
Dim source_rows As Integer
Dim source_range As Range
Set source_range = Sheets("SourceSheet").Range("a1:LB77")
Dim destination_range As Range
Set destination_range = Sheets("targetSheet").Range("a1")
source_cols = source_range.Columns.Count
source_rows = source_range.Rows.Count
Dim col As Integer
Dim row As Integer
For row = 1 To source_rows
For col = 1 To source_cols
'Copy value
destination_range.Offset(row - 1, col - 1).Value = source_range.Cells(row, col).Value
'Copy some extra styling if needed
destination_range.Offset(row - 1, col - 1).Interior.Color = source_range.Cells(row, col).Interior.Color
destination_range.Offset(row - 1, col - 1).Font.Color = source_range.Cells(row, col).Font.Color
destination_range.Offset(row - 1, col - 1).Font.Bold = source_range.Cells(row, col).Font.Bold
Next col
Next row
Application.ScreenUpdating = True
End Sub
However, I am recommending copy file (or worksheet at least) to remove filter, copy entire range and delete file/sheet that you just copied.
I'm filtering on a helper cell to locate cells in column B that need the contents cleared. Once I filter on the helper cell that has identified cells in column B that need contents cleared, I am having issues clearing the contents in that cell.
I got the general idea down except I cannot figure out how to clear the visible cells only starting from the first visible cell down to the last visible cell. My issue is identifying where is the start of the first visible cell after the filter is applied and where is the last visible cell.
Sub Macro1()
'
' Macro1 Macro
Dim wb As Workbook
Dim ws As Worksheet
Dim FoundCell1 As Range
Set wb = ActiveWorkbook
Set ws = ActiveSheet
'This identifying the row of the last cell to filter on
Const WHAT_TO_FIND1 As String = "Tango"
Set FoundCell1 = ws.Range("AX:AX").Find(What:=WHAT_TO_FIND1)
'This is filtering on the helper cell to determine what cells need to be cleared.
ws.Range("$BA$8:$BA$" & FoundCell1.Row).AutoFilter Field:=1, Criteria1:= _
"Delete"
'This is where I'm having issues. I would like to replace B2 with a more dynamic code
'that finds the first visible cell after the filter is applied and start there.
'I think the xlUp solves the issue of finding the last visible cell but I am not sure
'if that is the best or correct method.
ws.Range("B2:B" & Rows.Count).End(xlUp).SpecialCells(xlCellTypeVisible).ClearContents
End Sub
Here's how I'd do it:
Sub tgr()
Dim wb As Workbook
Dim ws As Worksheet
Dim FoundCell1 As Range
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
'This identifying the row of the last cell to filter on
Const WHAT_TO_FIND1 As String = "Tango"
Set FoundCell1 = ws.Range("AX:AX").Find(What:=WHAT_TO_FIND1)
If FoundCell1 Is Nothing Then Exit Sub 'WHAT_TO_FIND1 not found
'This is filtering on the helper cell to determine what cells need to be cleared.
With ws.Range("$BA$8:$BA$" & FoundCell1.Row)
If .Row < 8 Or .Rows.Count = 1 Then Exit Sub 'No data
.AutoFilter Field:=1, Criteria1:="Delete"
On Error Resume Next 'Suppress error in case there are no visible cells
Intersect(.Worksheet.Columns("B"), .Offset(1).Resize(.Rows.Count - 1).EntireRow).SpecialCells(xlCellTypeVisible).ClearContents
On Error GoTo 0 'Remove "On Error Resume Next" condition
.AutoFilter
End With
End Sub
I want to create a copy of a tab named Base for every value contained in a single array on a tab called List.
Each copy of the Base tab needs to be named each value contained on the List tab. Cell C1 on Base needs to be set to the value from the array List (which will also be the name of the tab).
The list will contain 300ish values, and having each tab in workbook as a copy of the original will oddly be the best solution for what will be a shared workbook.
I would like to flatten each worksheet to static values. Each worksheet with have a number of formulas that will cause performance issues if I leave as dynamic content.
Here is my code.
Sub Generator()
Dim cell As Range
Dim b As String
Dim e As String
Dim s As Integer
Sheets("List").Select
b = "A1"
e = Range(b).End(xlDown).Address
For Each cell In Range(b, e)
s = Sheets.Count
Sheets("Base").Copy After:=Sheets(s)
Range("C1").Select
ActiveCell.FormulaR1C1 = cell.Value
Sheets(s + 1).Name = cell.Value
Next cell
End Sub
After trying the solution, the only change is that I would like to re-calc the whole sheet (the functional equivalent of pushing the F9 key) after the new sheet is pasted but right before the sheet is flattened. I assume a line of code needs to be inserted as indicated below in the LetUsContinue sub.
LetUsContinue:
On Error GoTo 0 '--Turn off error handling.
.Range("C1") = Cell.Value '--Change C1 to the name of current sheet.
'---->>>>>recalc the sheet here
.Cells.Copy '--Change all cells...
.Cells.PasteSpecial xlPasteValues '--... to values.
End With
Next Cell
Try this:
Sub MoreAndMoreSheets()
Dim ListSh As Worksheet, BaseSh As Worksheet
Dim NewSh As Worksheet
Dim ListOfNames As Range, LRow As Long, Cell As Range
With ThisWorkbook
Set ListSh = .Sheets("List") '--Qualify our sheets.
Set BaseSh = .Sheets("Base")
End With
LRow = ListSh.Cells(Rows.Count, "A").End(xlUp).Row '--Get last row of list.
Set ListOfNames = ListSh.Range("A1:A" & LRow) '--Qualify our list.
With Application
.ScreenUpdating = False '--Turn off flicker.
.Calculation = xlCalculationManual '--Turn off calculations.
End With
For Each Cell In ListOfNames '--For every name in list...
BaseSh.Copy After:=Sheets(Sheets.Count) '--Copy Base sheet.
Set NewSh = ActiveSheet '--Let's name it NewSh.
With NewSh
On Error GoTo Boom '--In case of errors.
.Name = Cell.Value '--Set the sheet's name to that of our current name in list.
GoTo LetUsContinue '--Skip to the LetUsContinue block.
Boom: '--In case of duplicate names...
.Name = "Dup" & Cell.Value '--Add "Dup" to beginning.
.Tab.ColorIndex = 53 '--Change the tab color of the duplicate tab to orange for easy ID.
LetUsContinue:
On Error GoTo 0 '--Turn off error handling.
.Range("C1") = Cell.Value '--Change C1 to the name of current sheet.
.Calculate '--Calculate page.
.Cells.Copy '--Change all cells...
.Cells.PasteSpecial xlPasteValues '--... to values.
End With
Next Cell
With Application
.ScreenUpdating = True '--Return to proper state.
.Calculation = xlCalculationAutomatic '--Return to automatic calculation.
End With
BaseSh.Activate '--Select Base.
MsgBox "Done!" '--Done!
End Sub
Screenshots:
Set-up:
Result after running code:
Read the comments. Hope this helps. :)