looping through each COLUMN and finding highlighted cell - vba

I am having difficulty looping through each column before looping through the next row. The number of columns is fixed (A:K) with an unknown number of rows. The goal is to find highlighted cells (no distinct color.. and I figured the best way to do this is to code "If Not No Fill") and copy that whole row to another workbook. This is what I have so far and I am stuck:
Option Explicit
Sub Approval_Flow()
Dim AppFlowWkb As Workbook, ConfigWkb As Workbook
Dim AppFlowWkst As Worksheet, ConfigWkst As Worksheet
Dim header As Range, headerend As Range
Dim row As Long, column As Long
Set AppFlowWkb = Workbooks.Open("C:\Users\clara\Documents\Templates and Scripts\Approval Flow Change Log.xlsx")
Set ConfigWkb = ThisWorkbook
Set AppFlowWkst = AppFlowWkb.Sheets("Editor")
Set ConfigWkst = ConfigWkb.Worksheets("Approval Flows")
With ConfigWkb
Set header = Range("A7").Cells
If Not header Is Nothing Then
Set headerend = header.End(xlDown).row
For row = 7 To headerend
For j = 1 To 11
'if cell is filled (If Not No Fill), copy that whole row to another workbook
End With
End Sub
I am getting an error with the Set headerend line, but I am trying to select the last row to use it in my for loop. I appreciate any help and guidance. Thanks in advance!

You should be able to adapt this to suit your workbooks, see the comments for details
Dim aCell as Range
' Use UsedRange to get the variable number of rows,
' cycle through all the cells in that range
For Each aCell In ActiveSheet.Range("A1:K" & ActiveSheet.UsedRange.Rows.Count)
' Test if fill colour is white (none)
If Not aCell.Interior.Color = RGB(255,255,255) Then
' Insert new row in target sheet (could find last row instead)
ActiveWorkbook.Sheets("ThisOtherSheet").Range("A1").EntireRow.Insert
' Paste entire row into target sheet
aCell.EntireRow.Copy Destination:=ActiveWorkbook.Sheets("ThisOtherSheet").Range("A1")
End If
Next aCell
Alternatively to find the last row, if you know the range is continuous (no blanks) then you can use End(xlDown) like you had done, and like below
For Each aCell In ActiveSheet.Range("A1:K" & ActiveSheet.Range("K1").End(xlDown))
I'd guess you don't want to copy the same row multiple times if you've already copied it. You could do this by keeping an array or string with previously copied row numbers and checking before copying again, or use Excel's unique functions to strip the list down after copying.
Hope this helps.
Aside:
You're using a With block but not taking advantage of it, you need to put a dot . before your Range objects to specify that they're in your With sheet. Like so
Dim myRange as Range
With ActiveSheet
Set myRange = .Range("A1:C10")
End With

You're mixing the types.
It looks like you just want to use the Row that the Header data ends on.
Take out the .Row there, since you're setting headerend to be a cell address, not a specific value. Then change For row = 7 To headerend to For row = 7 To headerend.Row
Or, change Dim Headerend as Range to ...as Long and just do headerEnd = header.End(xlDown).Row (don't use Set)

Related

Returning value from wkbk 1 to wkbk 2 based on match result

I've commented my code below. I'm trying to loop through current workbook to search for cells that have a blue border (im currently testing only with Col A).
If cells have a blue border, then I want to find the matching cell on the 2nd workbook (The range will always be Column A and the 2nd workbook SHOULD always have a matching value).
When the match is found, I want to return the value from the 1st workbook (formatting included) to the 2nd workbook in the same row the match was found but in the next available column. Most of the time it will just be Column B, but if Col B is filled then move to column C etc.)
The match function works and is returning the correct idCella.value.
and resultM is saying the correct row of the match found, but I'm not sure how to continue.
I know I need to .offset(0,1) the resultM but I'm missing something and I'm not sure what.
Hopefully the description helps, but if you need anymore info please let me know!
EDIT: When I say find the exact match, the value on the 2nd workbook will not have the same blue border/interior.color. I just want to find the match of the cell.value. That may be redundant to say, but thought I would add it. I'm still learning :).
Dim testWS As Worksheet
Dim testRange As Range, rr2Dest As Range, idCella As Range
Dim alastRow2 As Long, resultM As Long
Set testWS = Workbooks("Test.xlsx").Worksheets("October") 'set the 2nd workbook as testWS
Set testRange = testWS.Columns(1) 'searching only column A on testWS (2nd workbook)
alastRow2 = Worksheets("Reruns To Pull").Cells(Rows.Count, "A").End(xlUp).Row 'find last row in column A that has data on current workbook
For Each idCella In Worksheets("Reruns To Pull").Range("A1:A" & alastRow2).Cells 'for each cell in Column A on current workbook (eventually I want to loop through Column A, D, G, J. All will be variable ranges)
If idCella.Borders.Color = RGB(0, 0, 192) Then 'On current workbook, if cells in Col A borders.color = blue then
resultM = Application.Match(idCella.Value, testRange, 0) 'find exact match on Test.xlsx (2nd workbook) and store in variable resultM
'look up value is the first cell found on current workbook that has blue border
'the range I want to search is column A of Test.xlsx
Set rr2Dest.Value = resultM 'trying to set this result to a variable so I can offset the range location by 1 column (Result from current workbook goes to Column B on Tets.xlsx workbook)
rr2Dest.Value = idCella.Value
rr2Dest.Interior.Color = idCella.Interior.Color 'everything I want to transfer into Column B on the 2nd workbook
rr2Dest.Borders.Color = idCella.Borders.Color
rr2Dest.Borders.Weight = idCella.Borders.Weight
End If
Next idCella
End Sub```
Start from rr2Dest and use .End(xlToRight).Column to get the next free cell and then update the value (and color, weight etc.) of this cell.
https://learn.microsoft.com/en-us/office/vba/api/excel.range.end
Set rr2dest = testWS.Range("A" & CStr(resultM)).Offset(0, 1)
Solved the issue. Didn't realize the macro wasn't keeping track of what workbook it was on. So once I specified that and used CStr in combination with my variable containing the match.
Just have to throw in Schutt's answer and it should be good to go.

Vba clear contents of a certain range or cell

How can I clear the column and row starting with a reference cell?
I used
For x = 1 To 20
Sheets(1).Columns(x).ClearContents
Next x
But I want to be able to clear the contents of all rows and columns starting with row A6 as a reference point. I cant use range since the data is dynamic and changes upon insertion of data. The data came from a csv
Since your question states "I want to be able to clear the contents of all rows and columns starting with row A6 as a reference point." Then here is a one liner using SpecialCells(xlLastCell)
ActiveSheet.Range("A6", ActiveCell.SpecialCells(xlLastCell)).Clear
If your range starts at A6 and is continuous with no blanks in Row 6 and no blanks in Column A, you could set the range like this:
'Create variables
Dim wb as Workbook
Dim ws as Worksheet
Dim rng as Range
'Initialize variables
set wb = ActiveWorkbook
set ws = ActiveSheet
lastrow = ws.Range("A6").End(xlDown).Row
lastcol = ws.Range("A6").End(xlToRight).Column
'Set the range
set rng = ws.Range(Cells(6,1),Cells(lastrow,lastcol))
'Clear contents
rng.ClearContents
This uses Range.Endproperty of the Range object. It's basically like clicking on A6 and hitting ctrl+right on your keyboard and then returning the range.
Note: If there are gaps in the range you won't get the correct result.

Remove rows from selectrange VBA

Im trying to write a VBA to copy and paste alot of different data, there is a lot of non-important data in each sheet so i want to copy only the important part.
The VBA i have now looks like this:
Sub DynamicRange()
'Best used when your data does not have any entirely blank rows or columns
Dim sht As Worksheet
Dim StartCell As Range
Set sht = Worksheets("Kvalitetskriterier 2015")
Set StartCell = Range("A8")
'Select Range
StartCell.CurrentRegion.Select
End Sub
What I need is a way to, from the seleced range, remove the first row and the last 4 rows as i dont need that part. Is there a way to do that from my VBA?
There's no need to Select the range if you want to copy it, you can directly Copy it.
if you want to get rid of the first row of the Range, you can use Range.Ofset(1, 0), this will remove the first row (Header).
If you also want to get rid of rows at the end of your Range, you can use Range.Resize(- number of rows you want to remove).
Code
Sub DynamicRange()
'Best used when your data does not have any entirely blank rows or columns
Dim sht As Worksheet
Dim StartCell As Range
Set sht = Worksheets("Kvalitetskriterier 2015")
Set StartCell = sht.Range("A8")
'Select current region
Set StartCell = StartCell.CurrentRegion
' set offeset 1 row (remove header), and use Resize to remove the last row
Set StartCell = StartCell.Offset(1, 0).Resize(StartCell.rows.Count - 2)
StartCell.Copy ' <-- No need to Select it if you want to copy
End Sub

How to loop a dynamic range and copy select information within that range to another sheet

I have already created a VBA script that is about 160 lines long, which produces the report that you see below.
Without using cell references (because the date ranges will change each time I run this) I now need to take the users ID, name, total hours, total break, overtime 1, and overtime 2 and copy this data into sheet 2.
Any suggestions as to how I can structure a VBA script to search row B until a blank is found, when a blank is found, copy the values from column J, K, L, M on that row, and on the row above copy value C - now paste these values on sheet 2. - Continue this process until you find two consecutive blanks or the end of the data...
Even if you can suggest a different way to tackle this problem than the logic I have assumed above it would be greatly appreciated. I can share the whole code if you are interested and show you the data I began with.
Thank you in advance,
J
As discussed, here's my approach. All the details are in the code's comments so make sure you read them.
Sub GetUserNameTotals()
Dim ShTarget As Worksheet: Set ShTarget = ThisWorkbook.Sheets("Sheet1")
Dim ShPaste As Worksheet: Set ShPaste = ThisWorkbook.Sheets("Sheet2")
Dim RngTarget As Range: Set RngTarget = ShTarget.UsedRange
Dim RngTargetVisible As Range, CellRef As Range, ColRef As Range, RngNames As Range
Dim ColIDIndex As Long: ColIDIndex = Application.Match("ID", RngTarget.Rows(1), 0)
Dim LRow As Long: LRow = RngTarget.SpecialCells(xlCellTypeLastCell).Row
'Turn off AutoFilter to avoid errors.
ShTarget.AutoFilterMode = False
'Logic: Apply filter on the UserName column, selecting blanks. We then get two essential ranges.
'RngTargetVisible is the visible range of stats. ColRef is the visible first column of stats.
With RngTarget
.AutoFilter Field:=ColIDIndex, Criteria1:="=", Operator:=xlFilterValues, VisibleDropDown:=True
Set RngTargetVisible = .Range("J2:M" & LRow).SpecialCells(xlCellTypeVisible)
Set ColRef = .Range("J2:J" & LRow).SpecialCells(xlCellTypeVisible)
End With
'Logic: For each cell in the first column of stats, let's get its offset one cell above
'and 7 cells to the left. This method is not necessary. Simply assigning ColRef to Column C's
'visible cells and changing below to CellRef.Offset(-1,0) is alright. I chose this way so it's
'easier to visualize the approach. RngNames is a consolidation of the cells with ranges, which we'll
'copy first before the stats.
For Each CellRef In ColRef
If RngNames Is Nothing Then
Set RngNames = CellRef.Offset(-1, -7)
Else
Set RngNames = Union(RngNames, CellRef.Offset(-1, -7))
End If
Next CellRef
'Copy the names first, then RngTargetVisible, which are the total stats. Copying headers is up
'to you. Of course, modify as necessary.
RngNames.Copy ShPaste.Range("A1")
RngTargetVisible.Copy ShPaste.Range("B1")
End Sub
Screenshots:
Set-up:
Result:
Demo video here:
Using Filters and Visible Cells
Let us know if this helps.

Copy cells between workbooks

Could someone please help me with some VBA code.
I am trying to copy 2 ranges of cells between workbooks (both workbooks should be created beforehand as i don't want the code to create a new workbook on the fly).
Firstly I need to copy these ranges-
From 'Sheet 3' of booka.xls, Range: Cell H5 to the last row in column H with data
copy this to 'Sheet 1' of bookb.xls, starting in Cell B2 for as many cells down in the B column
Secondly I need to copy these ranges-
From 'Sheet 3' of booka.xls, Range: Cell K5 to the last row in column K with data
copy this to 'Sheet 1' of bookb.xls, starting in Cell D2 for as many cells down in the D column
Here is what I have so far:
Sub CopyDataBetweenBooks()
Dim iRow As Long
Dim wksFr As Worksheet
Dim wksTo As Worksheet
wksFr = "C:\booka.xls"
wksTo = "C:\bookb.xls"
Set wksFrom = Workbooks(wksFr).Worksheets("Sheet 3")
Set wksTo = Workbooks(wksTo).Worksheets("Sheet 1")
With wksFrom
For iRow = 1 To 100
.Range(.Cells(iRow, 8), .Cells(iRow, 9)).Copy wksTo.Cells(iRow, 8)
Next iRow
End With
End Sub
Assuming you have the reference to wksFrom and wksTo, here is what the code should be
wksFrom.Range(wksFrom.Range("H5"), wksFrom.Range("H5").End(xlDown)).Copy wksTo.Range("B2")
wksFrom.Range(wksFrom.Range("K5"), wksFrom.Range("K5").End(xlDown)).Copy wksTo.Range("D2")
Here's an example of how to do one of the columns:
Option Explicit
Sub CopyCells()
Dim wkbkorigin As Workbook
Dim wkbkdestination As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim lastrow As Integer
Set wkbkorigin = Workbooks.Open("booka.xlsm")
Set wkbkdestination = Workbooks.Open("bookb.xlsm")
Set originsheet = wkbkorigin.Worksheets("Sheet3")
Set destsheet = wkbkdestination.Worksheets("Sheet1")
lastrow = originsheet.Range("H5").End(xlDown).Row
originsheet.Range("H5:H" & lastrow).Copy 'I corrected the ranges, as I had the src
destsheet.Range("B2:B" & (2 + lastrow)).PasteSpecial 'and destination ranges reversed
End Sub
As you have stated in the comments, this code above will not work for ranges with spaces, so substitute in the code below for the lastrow line:
lastrow = originsheet.range("H65536").End(xlUp).Row
Now ideally, you could make this into a subroutine that took in an origin workbook name, worksheet name/number, and range, as well as a destination workbook name, worksheet name/number, and range. Then you wouldn't have to repeat some of the code.
You can use special cells like Jonsca has suggested. However, I usually just loop through the cells. I find it gives me more control over what exactly I am copying. There is a very small effect on performance. However, I feel that in the office place, making sure the data is accurate and complete is the priority. I wrote a response to a question similar to this one that can be found here:
StackOverflow - Copying Cells in VBA for Beginners
There is also a small demonstration by iDevelop on how to use special cells for the same purpose. I think that it will help you. Good luck!
Update
In response to...
good start but it doesn't copy anything after the first blank cell – trunks Jun 9 '11 at 5:08
I just wanted to add that the tutorial in the link above will address the issue brought up in your comment. Instead of using the .End(xlDown) method, loop through the cells until you reach the last row, which you retrieve using .UsedRange.Rows.Count.