Copy/Paste Yellow Highlighted Cells in a new WorkSheet VBA - excel

I'm trying to get this one done.
This macro should open a workbook (workbook names always change and there's always just one sheet to process). This works.
Set the range for the whole sheet; works fine.
And search the entire sheet for cells highlighted in yellow, and copy these cells into a new sheet... and this is where I need help!
I am really new to VBA and thats what I have so far:
Option Explicit
Sub test3()
Dim data As Variant
Dim rngTemp As Range
Dim cell As Range
'//open Workbook
data = Application.GetOpenFilename(, , "Open Workbook")
Workbooks.Open data
'// set Range ( Whole Sheet)
Set rngTemp = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
If Not rngTemp Is Nothing Then
Range(Cells(1, 1), rngTemp).Select
End If
'// Search for Yellow highlighted Cells and (if you find one)
'// Copy Cell B1 + the 3rd Cell in the column (of the highlighted Cell) + the value highlighted Cell
'// and paste in new Sheet
For Each cell In rngTemp.Cells
If rngTemp.Interior.ColorIndex = 6 Then
cell.Select
Selection.Copy
Sheets.Add
Range("A1").PasteSpecial
Application.CutCopyMode = False
End If
Next
End Sub

Sub test3()
Dim wbName As string
Dim rngTemp As Range
Dim r As Range
DIM TARGETSHEET AS WORKSHEET
DIM TARGET AS RANGE
'//open Workbook
wbName = Application.GetOpenFilename(, , "Open Workbook")
if wbName = "" or wbname = "CANCEL" then exit sub
Workbooks.Open wbname
'// set Range ( Whole Sheet)
Set rngTemp = Activesheet.usedrange
SET TARGETSHEET = ACTIVEWORKBOOK.WORKSHEETS.ADD()
SET TARGET = TARGETSHEET.RANGE("A1")
'// Search for Yellow highlighted Cells and (if you find one)
'// Copy Cell B1 + the 3rd Cell in the Column (of the highlighted Cell) + the value highlighted Cell
'// and paste in new Sheet
For Each r In rngTemp
If r.Interior.ColorIndex = 6 Then
TARGET = rngtemp.parent.range("B1")
TARGET.OFFSET(0,1) = r
TARGET.OFFSTE(0,2) = rngtemp.parent.cells(3,r.column)
'I've assumed you want them across the first row
SET TARGET = TARGET.OFFSET(1,0)
End If
Next r
End Sub

Related

How to copy cells of specific colour of a worksheet and paste them in another workbook

I am very new to VBA and I was wondering how to copy only the white cells of a worksheet and paste them to the same places but to another workbook.
Specifically, I have two workbooks with multiple sheets and they are the same, but the source workbook has some white cells filled and the destination workbook has these cells empty. I want to transfer the values from the source white cells to the destination white cells.
Also if it is possible, I want to fill the empty white cells with "0".
I have found some pieces of code to copy all coloured cells to another excel worksheet but they do not transfer to another workbook and the exact places.
Sub CopyHighlightedTransactions()
Dim TransIDField As Range
Dim TransIDCell As Range
Dim ATransWS As Worksheet
Dim HTransWS As Worksheet
Set ATransWS = Worksheets("All Transactions")
Set TransIDField = ATransWS.Range("A2", ATransWS.Range("A2").End(xlDown))
Set HTransWS = Worksheets("Highlighted Transactions")
For Each TransIDCell In TransIDField
If TransIDCell.Interior.Color = RGB(255, 0, 0) Then
TransIDCell.Resize(1, 10).Copy Destination:= _
HTransWS.Range("A1").Offset(HTransWS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
End If
Next TransIDCell
HTransWS.Columns.AutoFit
End Sub
Thank you in advance.
If the animation above is something that you mean (if I understand you correctly), maybe you want to try the sub below :
Sub test()
Dim wbS As Worksheet: Dim wbT As Worksheet
Dim rgData As Range: Dim c As Range
Application.ScreenUpdating = False
'prepare variable for the workbook and sheet of the source and target
Set wbS = Workbooks("Source.xlsm").Sheets("Sheet1") 'change as needed
Set wbT = Workbooks("Target.xlsx").Sheets("Sheet1") 'change as needed
'the range of the data to be searched
Set rgData = wbS.Range("A1:D10") 'change as needed
'prepare the color to be searched
With Application.FindFormat
.Clear
.Interior.Color = vbWhite
End With
'start searching as c variable
Set c = rgData.Find(What:=vbNullString, SearchFormat:=True)
'loop until all cells in rgData is checked if the color is white or not
'if found white then copy the c, paste to wbT with that c address
If Not c Is Nothing Then
FirstAddress = c.Address
Do
c.Copy Destination:=wbT.Range(c.Address)
Set c = rgData.Find(What:=vbNullString, after:=c, SearchFormat:=True)
Loop While c.Address <> FirstAddress
End If
End Sub
To test the code, make a copy of your workbook (both the source and the target). Copy the sub, paste on the copied workbook then run it. Both workbooks must be opened. It will take time if your data range is big as the code will check all the cell which has white color within the rgData.
the source workbook has some white cells filled
Please remember, the code is looking for the cell which is filled with white color.
I'm curious if the test2 sub below is faster because there's no loop.
Sub test2()
Dim rgW_orig As Range: Dim rgDest As Range
Dim rgW As Range: Dim rgX As Range
Dim rgBlank As range
Application.ScreenUpdating = False
Set rgW_orig = Sheets(1).Range("A1:D10")
Set rgDest = Workbooks("Target.xlsx").Sheets(1).Range(rgW_orig.Address)
With Application.FindFormat.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Workbooks.Add
Set rgW = ActiveSheet.Range(rgW_orig.Address)
rgW_orig.Copy Destination:=rgW
With rgW
.Replace What:="", Replacement:=True, LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=False
Set rgX = .SpecialCells(xlConstants, xlLogical)
End With
rgW.Value = "": rgX.Value = 1
set rgBlank = rgW.SpecialCells(xlBlanks)
rgW.Value = rgW_orig.Value
rgBlank.ClearContents
rgW.Copy
rgDest.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
True, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Close False
End Sub
The test2 macro use a new workbook as a helper, and assumes that the range of data in the Source.xlsm (where the macro reside) is the same within the range of data in the Target.xlsx.
First, it set a range the same address with rgW_orig in the new workbook as rgW variable. Then it copy the rgW_orig and paste it to rgW
Then within the new workbook (the helper workbook) :
it get all cells which filled with white color (by replacing the cell with white color with TRUE boolean), set it as rgX variable.
Next, it fill the whole range (the rgW) with blank, and fill the rgX with 1, then get all cells which has no value (blank) as rgBlank variable.
It copy again the rgW_orig into rgW, then clear the content of rgBlank. Now in this helper workbook within the rgW, the cells with value are only the one with white color, the rest are blank.
Finally it copy the rgW, paste "skip blank" into rgDest then close the helper workbook without saving.
Still not so sure though if this test2 sub is faster than the sub before.

How to reference last used column in a certain row and paste certain value in there

I am working on a macro that loops over a the used range in one sheet (which is the last sheet in the workbook) in a certain column ("H"). The macro should then copy the value, only if it is not 0, and paste it in a sheet called "Overview" in the original row, offset by 3 (e.g. first row becomes 4th row) and in the column behind the last used column in row 5. (I hope that makes sense?). I already worked on some code but I did not manage to reference the last used column correctly and am honestly close to a breakdown.
can someone explain to me what I am doing wrong?
This is what I already have:
Dim Cell As Range, cRange As Range, lrw As Long
Dim wsDestination As Worksheet, wsSource As Worksheet
'set worksheets
With ThisWorkbook
Set wsSource = .Worksheets(Sheets.Count)
Set wsDestination = .Worksheets("Overview")
End With
LastRow1 = wsSource.Cells(Rows.Count, "H").End(xlUp).Row
LastColumn1 = wsDestination.Cells(5, "A").End(xlRight).Column
Set cRange = wsSource.Range(wsSource.Cells(1, 8), wsSource.Cells(LastRow1, 8))
For Each Cell In cRange.Cells
If Cell.Value > 0 Then wsDestination.Cells(Cell.Row, LastColumn1).offset(3, 1) = Cell.Value
Next Cell
End Sub```
The Subtle Differences in Ways of Finding the 'Last Column'
To successfully test the first procedure, in a new worksheet you have to:
write a value in cell A1,
write ="" in cell B1,
write a value in cell C1,
hide column C
and use a fill color in cell D1.
The result of the test will be shown in the Immediate window CTRL+G.
The third procedure is an example of how to use the second procedure, the function for calculating the column of the last non-blank cell in a row using the Find method.
The Code
Option Explicit
Sub LastColumnSuptileDifferences()
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet1")
' Cell Value Comment
' A1: 1 Value
' B1: ="" Formula
' C1 1 Value: Hidden Column
' D1: Fill Color
Debug.Print ws.Rows(1).Find("*", , xlFormulas, , , xlPrevious).Column ' 3
Debug.Print ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column ' 2
Debug.Print ws.Rows(1).Find("*", , xlValues, , , xlPrevious).Column ' 1
Debug.Print ws.Rows(1).CurrentRegion.Columns.Count ' 3
Debug.Print ws.Rows(1).SpecialCells(xlCellTypeLastCell).Column ' 4
Debug.Print ws.UsedRange.Rows(1).Columns.Count ' 4
End Sub
' This will find the last column even if columns are hidden
' unless you set 'excludeEmpties' to 'True'.
' If you set 'excludeEmpties' to 'True', the right-most cells in the row,
' possibly containing a formula that evaluates to "", will be skipped.
' Additionally only the visible cells will be included, i.e. hidden
' right-most columns, possibly containing data in cells of the row,
' will not be considered (mimicking 'End(xlToLeft)' or CRTL+Left).
Function getLastColumnInRow(RowNumber As Variant, _
Optional Sheet As Worksheet = Nothing, _
Optional excludeEmpties As Boolean = False)
If Sheet Is Nothing Then
Set Sheet = ActiveSheet
End If
Dim FormVal As XlFindLookIn
If excludeEmpties Then
FormVal = xlValues
Else
FormVal = xlFormulas
End If
Dim rng As Range
Set rng = Sheet.Rows(RowNumber).Find(What:="*", _
LookIn:=FormVal, _
SearchDirection:=xlPrevious)
If Not rng Is Nothing Then
getLastColumnInRow = rng.Column
Else
getLastColumnInRow = 0
End If
End Function
Sub testgetLastColumnInRow()
'...
LastColumn1 = getLastColumnInRow(5, wsDestination)
If LastColumn1 = 0 Then
MsgBox "No Data.", vbExclamation, "Empty Row"
Exit Sub ' or whatever
End If
' Continue with code.
Debug.Print LastColumn1
'...
End Sub
So you didn't quite get the last column right. Here's it back.
Dim Cell As Range, cRange As Range, lrw As Long
Dim wsDestination As Worksheet, wsSource As Worksheet
'set worksheets
With ThisWorkbook
Set wsSource = .Worksheets(Sheets.Count)
Set wsDestination = .Worksheets("Overview")
End With
LastRow1 = wsSource.Cells(Rows.Count, "H").End(xlUp).Row
LastColumn1 = wsDestination.Cells(5, columns.count).End(xltoleft).Column
Set cRange = wsSource.Range(wsSource.Cells(1, 8), wsSource.Cells(LastRow1, 8))
For Each Cell In cRange.Cells
If Cell.Value > 0 Then wsDestination.Cells(Cell.Row, LastColumn1).offset(3, 1) = Cell.Value
Next Cell
End Sub```

Copy range of values between workbooks

I am trying to copy either single cells values or rows of cells from a source workbook to a target workbook.
The user will have three workbooks open:
Dashboard workbook
Source workbook
Target workbook
The sub reads the user input in Dashboard workbook, which will look like the following:
Source cells Target cells Cell/Row
G28 H30 Cell
G29 H31 Row
The sub is then supposed to look up cell G28 in Source workbook and copy that into H30 in Target workbook. Likewise the sub is supposed to look up cell G29 in Source workbook and copy that cell and everything to the right into H31 in Target workbook.
I managed to copy single cell values. I have not been able to implement the functionality for the row type input.
I indicated below where the error is.
Sub transferSub()
Dim wbMain As Workbook: Set wbMain = ThisWorkbook
Dim wbMainDashboard As Worksheet: Set wbMainDashboard = wbMain.Worksheets("Dashboard")
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
'Definition of file path for source and target workbooks
sourceModel = wbMainDashboard.Range("FILE_SOURCE") 'Pull from dashboard input
targetModel = wbMainDashboard.Range("FILE_TARGET") 'Pull from dashboard input
'Source and target workbooks
Dim wbSource As Workbook: Set wbSource = Workbooks(sourceModel) 'Workbook already open
Dim wbTarget As Workbook: Set wbTarget = Workbooks(targetModel) 'Workbook already open
'Source and target worksheet
Dim wskpInput_source As Worksheet: Set wskpInput_source = wbSource.Worksheets("INPUT (kp)")
Dim wsSCEInput_source As Worksheet: Set wsSCEInput_source = wbSource.Worksheets("INPUT (SCE)")
'Source and target worksheet
Dim wskpInput_target As Worksheet: Set wskpInput_target = wbTarget.Worksheets("INPUT (kp)")
Dim wsSCEInput_target As Worksheet: Set wsSCEInput_target = wbTarget.Worksheets("INPUT (SCE)")
'Procedures
Dim rng As Range: Set rng = wbMainDashboard.Range("Dashboard!E9:E15")
Dim i As Integer
For i = 1 To rng.Rows.Count
cell_source = rng.Cells(i, 1)
cell_target = rng.Cells(i, 1).Offset(0, 1)
cell_cellrow = rng.Cells(i, 1).Offset(0, 3)
If cell_cellrow = "Cell" Then 'If cell then copy paste value in that cell
wskpInput_target.Range(cell_target) = wskpInput_source.Range(cell_source).Value
ElseIf cell_cellrow = "Row" Then 'If row then copy and paste the row of cells
wskpInput_source.Range(cell_source, cell_source.End(xlToRight)).Copy _
wskpInput_target.Range(cell_target) '---NEED HELP WITH THIS PART---
End If
Next
End Sub
Well, the Range object can either get Cells as arguments or a String (details here).
Hard-coding the range with a string argument would look like this:
wskpInput_source.Range("G28:L28").Copy _
destination:=wskpInput_target.Range(cell_target)
but since you already have a variable containing the first cell ("G28") in the row, we only need to find the last cell, you can get it with a Function like the following:
Function GetLastCellInRow(sheetName As String, firstCell As String) As String
Sheets(sheetName).Range(firstCell).End(xlToRight).Select
GetLastCellInRow = ActiveCell.Address
End Function
and this is how you call it
'MySheet is the source sheet, so you need to modify that
cell_source_last = GetLastCellInRow(MySheet.Name, cell_source)
And putting all together:
cell_source = rng.Cells(i, 1)
cell_target = rng.Cells(i, 1).Offset(0, 1)
cell_cellrow = rng.Cells(i, 1).Offset(0, 3)
'MySheet is the source sheet, so you need to modify that
cell_source_last = GetLastCellInRow(MySheet.Name, cell_source)
If cell_cellrow = "Cell" Then 'If cell then copy paste value in that cell
wskpInput_target.Range(cell_target) = wskpInput_source.Range(cell_source).Value
ElseIf cell_cellrow = "Row" Then 'If row then copy and paste the row of cells
wskpInput_source.Range(cell_source & ":" & cell_source_last).Copy _
Destination:=wskpInput_target.Range(cell_target)
End If

How to copy an entire row to another sheet if a cell = true

I have 2 sheets, 'Initial' & 'Report1'. I'm trying to copy specific rows from 'Inital' to 'Report1' when the cell in column 'H' is = "On going".
I have the function as a button in excel but cant workout how to copy and paste the line and move onto the next cell.
Also, Column D is formula and needs to be pasted special to copy over.
I have attached the current code I have tried but it errors. Any help would be greatly appreciated.
Sub GenRep1_Click()
Dim Inti As Worksheet
Dim rep1 As Worksheet
Set Inti = ThisWorkbook.Worksheets("Inital")
Set rep1 = ThisWorkbook.Worksheets("Report1")
Dim rngA As Range
Dim cell As Range
Set rngA = Sheets("Inti").Range("H5:H9999")
For Each cell In rngA
If cell.Value = "On going" Then
cell.EntireRow.Copy
Sheets("Inti").Range("").End(xlDown).Select
ActiveSheet.Paste
End If
Next cell
End Sub
I expect the all rows in column 'H' that = "On Going" to be copied to "Report1".
I think this does what you want. You might want to improve the range you're looping through in case you only have, e.g. 100 cells of data.
A quicker approach than looping would be AutoFilter.
Sub GenRep1_Click()
Dim Inti As Worksheet
Dim rep1 As Worksheet
Set Inti = ThisWorkbook.Worksheets("Inital") 'check name - typo?
Set rep1 = ThisWorkbook.Worksheets("Report1")
Dim rngA As Range
Dim cell As Range
Set rngA = Inti.Range("H5:H9999") 'already defined worksheet so just use variable
'Set rngA = Inti.Range("H5",inti.range("H" & rows.count).end(xlup)) 'would be more efficient
For Each cell In rngA
If cell.Value = "On going" Then
cell.EntireRow.Copy
repl.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlValues 'copy to the other sheet
End If
Next cell
End Sub

VBA to copy certain columns to all worksheets

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

Resources