In essence, I want to compare two sheets, one containing data from Today, the other from Yesterday, and then copy the lines with changes to a third sheet.
The code I am currently using (seen below) mostly works but has a couple errors (also broken out below) that I want to iron out.
Sub Changed()
set wsa = Sheets("Today")
Set wsb = Sheets("Yesterday")
Set wse = Sheets("Line Changes")
Dim mycell as range
Dim mydiff as integer
For each mycell in wsa.usedrange
If Not mycell.Value = wsb.Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.Color = RGB(250, 250, 50)
mycell.Range("B").Interior.Color = RGB (250, 250, 50)
mycell.EntireRow.Copy wse.Range("A" & Rows.Count).xlUp).Offset(1)
End If
Next
End Sub
Breakdown of the individual desired functions and issues within the loop:
If Not mycell.Value = wsb.Cells(mycell.Row, mycell.Column).Value Then
Compare Sheets("Today") and Sheets("Yesterday") to find differences. This line works.
mycell.Interior.Color = RGB(250, 250, 50)
Highlight the changed items on Sheets("Today"). This line works.
mycell.Range("B").Interior.Color = RGB (250, 250, 50)
For reference, Column A is just a general reference number which has no real bearing on the rest of the data, but Column B contains an alpha-numeric code specific to the actual items in each line which is why I want to highlight column B instead of A if there are changes.
Highlight Column B in Sheets("Today") if there are changes in the line to allow for easy identification of lines containing changes. The issue I run into with this function is that it doesn't actually work. It doesn't give me an error message so I haven't been able to actually identify what the problem is. This particular function is not 100% necessary so I would be amenable to just removing it.
mycell.EntireRow.Copy wse.Range("A" & Rows.Count).xlUp).Offset(1)
Copy rows with changes from Sheets("Today") and paste it in Sheets("Line Changes"). The issue I run into with this function is it copies changed lines multiple times, once for every individual change.
For example, if Columns D,E,F, and G all have changes, "D" will be highlighted and the row will be copied, then "E" will be highlighted and the row will be copied, and so on. Obviously that's not ideal if there's dozens of lines with 5 or 6 changes each.
My main issue is with that last line, I think the easiest fix would be to remove it from the current loop and add it back in later in the code so it doesn't copy over every individual change but past attempts of mine to remove it broke everything. Its a pretty large document, (1500ish rows, 32 columns) so looping the same data potentially a couple hundred times tends to crash excel. Any suggestions to fix this issue or even streamline the process would be greatly appreciated.
HighLighting Differences: a Row Range Approach
The Code
Option Explicit
Sub Changed()
' Define workbook.
Dim wb As Workbook
Set wb = ThisWorkbook
' Define worksheets.
Dim wsa As Worksheet
Set wsa = wb.Worksheets("Today")
Dim wsb As Worksheet
Set wsb = wb.Worksheets("Yesterday")
Dim wse As Worksheet
Set wse = wb.Worksheets("Line Changes")
' Define Today Used Range.
Dim rng As Range
Set rng = wsa.UsedRange
Dim RowRange As Range
Dim cel As Range
Dim copyRow As Boolean
' Loop through rows of Today Used Range.
For Each RowRange In rng.Rows
' Initialize Copy Row Boolean.
copyRow = False
' Loop through each cell in current row of Today Used Range.
For Each cel In RowRange.Cells
' Ceck value in current cell on Today worksheet against the value
' of the same cell on Yesterday Worksheet.
If Not cel.Value = wsb.Cells(cel.Row, cel.Column).Value Then
' Set Copy Row Boolean to True indicating that this
' row will be copied and the value in "B" column will be
' hightlighted.
copyRow = True
' Highlight current cell in Today Worksheet.
cel.Interior.Color = RGB(250, 250, 50)
End If
Next cel
' If any differences have been found...
If copyRow Then
RowRange.Cells(2).Interior.Color = RGB(250, 250, 50)
RowRange.Copy wse.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
End Sub
Related
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.
how can I copy/paste rows from one workbook to another if the following conditions are met:
Copy all rows from the source workbook(wb.Source,sheet1) if they are from the actual month(column 8 containing true dates) and paste them to my master workbook(Wb) in sheet 3. Only copy the rows which have the first day of the month as date in column 8.
Example:
Lets say today is the 14.05.2020.
Triggering the macro would copy all rows from the source workbook with the date 01.05.2020(column 8) and paste them to wb in Sheet 3.
So the macro needs to refer to the Today function to able to say which month it actually is right now, and then in the next step to copy the rows which are frim the same month BUT only from the first day of said month.
Would appreciate any help!
Private Sub CommandButton3_Click()
Dim fname As String, wbSource As Workbook, wsSource As Worksheet
fname = Me.TextBox1.Text
If Len(fname) = 0 Then
MsgBox "No file selected", vbCritical, "Error"
Exit Sub
End If
Set wbSource = Workbooks.Open(fname, False, True) ' no link update, read only
Set wsSource = wbSource.Sheets("Sheet1") ' change to suit
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Table 3")
' Set your source and destination worksheets as objects here
Set wsSource = wbSource.Sheets("Sheet1")
Dim i As Long, destination_row As Long
Dim source_rng As Range, destination_rng As Range
destination_row = 1
For i = 1 To 10 ' See note below regarding for vs while loop for this
' Check dates only against cells that contain date values (in case there is a non-date value in one of the cells)
If VarType(wsSource.Cells(i, 8)) = vbDate Then
' Condition checks that the date is today
If Format(Now, "yyyy/mm/dd") = Format(wsSource.Cells(i, 8).Value2, "yyyy/mm/dd") Then
' Set source and destination ranges
Set source_rng = wsSource.Range(wsSource.Cells(i, 1), wsSource.Cells(i, 10000))
Set destination_rng = ws.Range(ws.Cells(destination_row, 1), destination_sheet.Cells(destination_row, 10000))
source_rng.Copy destination_rng ' Alternatively use destination_rng.Value2 = source_rng.Value2
destination_row = destination_row + 1 ' Iterate the destination row so that the next copy outputs to the next row
End If
End If
Next i
' close source worbook no save
wbSource.Close False
End Sub
The question was a little vague as to the formatting of the worksheets (which columns contain data, where you want to begin printing, if you know how many rows the source data is, if all cells within the data range are populated, etc.), but I've written an example here that can be tweaked to fit the worksheets you're using.
Option Explicit
Sub CopyRows()
' Set your source and destination worksheets as objects here
Dim source_sheet As Worksheet, destination_sheet As Worksheet
Set source_sheet = ActiveWorkbook.Sheets("A")
Set destination_sheet = ActiveWorkbook.Sheets("B")
Dim i As Long, destination_row As Long
Dim source_rng As Range, destination_rng As Range
destination_row = 1
For i = 1 To 10 ' See note below regarding for vs while loop for this
' Check dates only against cells that contain date values (in case there is a non-date value in one of the cells)
If VarType(source_sheet.Cells(i, 8)) = vbDate Then
' Condition checks that the date is today
If Format(Now, "yyyy/mm/dd") = Format(source_sheet.Cells(i, 8).Value2, "yyyy/mm/dd") Then
' Set source and destination ranges
Set source_rng = source_sheet.Range(source_sheet.Cells(i, 1), source_sheet.Cells(i, 10))
Set destination_rng = destination_sheet.Range(destination_sheet.Cells(destination_row, 1), destination_sheet.Cells(destination_row, 10))
source_rng.Copy destination_rng ' Alternatively use destination_rng.Value2 = source_rng.Value2
destination_row = destination_row + 1 ' Iterate the destination row so that the next copy outputs to the next row
End If
End If
Next i
End Sub
I've used sheets "A" and "B" as proxies for your source and destination worksheets. You need to set these objects to your actual source and destination worksheets in your code.
I've also initalized destination_row as 1, assuming you want the copied rows to be printed starting on the first row of the destination worksheet, but this can be set to 2 (if there are headers) or to any row you prefer the output starts on. You may want to add additional code to find the next empty row if you want the new rows to be added underneath whatever data already exists in the worksheet.
The for loop is written as a basic example, assuming that you know how many rows of data there are. If you expect the size of the source range to change (i.e. rows are often added and/or removed), you would want to either determine a final row before starting the loop (by using xlUp/xlDown or similar), or use a while loop instead of a for loop (if there is a column that is always populated that you can use as part of the while condition).
In the section where the source_rng and destination_rng are set, replace the numbers 1 and 10 with the first and last columns of the data (for example, if the data starts on column 3 and finishes on column 15, these should be changed to 3 and 15 respectively).
New to VBA
I'm confused as to why I need to run my module twice to get it to update my cells. My code:
Option Explicit
Sub m_Range_End_Method()
Dim lRow As Long
Dim lCol As Long
Dim currentRow As Long
Dim i As Integer
Dim rng As Range
Set rng = ActiveCell
Range("B:B").Select
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
Sheets("MySheet").Select
' Loop Through Cells to set description in each cell
Do While rng.Value <> Empty
currentRow = ActiveCell.Row
If InStr(rng.Value, "PETROL") = 0 Then
Set rng = rng.Offset(1)
rng.Select
Else
Worksheets("MySheet").Cells(currentRow, 5) = "Shopping"
Worksheets("MySheet").Cells(currentRow, 6) = "Car"
Set rng = rng.Offset(1)
rng.Select
End If
Loop
End Sub
On the first run what happens in Excel 2016 is that Column B gets highlighted and that's it. I then have to press "Run" again in visual basics editor for it to then update all the entries at which point column B gets unselected. All I want to do is update the cells at the currentRow of a specified worksheet. I've been reading but have got myself into some confusion, someone said I should use the
Range("B:B").Select
statement and for some reason the spreadsheet update works but only if I run it twice. Without this Range command, for reasons I don't understand, the spreadsheet doesn't update - all that happens is that the box selection moves to entries with Petrol and stays there with the program running but not updating.
The aim of the program is to find in a sheet all occurrences of a word in column B, in this initial case that is PETROL (I'm going to expand to include many others). For that match on the same row I want it to update columns 5 and 6 with descriptions. The excel spreadsheet will have hundreds of rows of entries with varying descriptions in column B.
Any help would be much appreciated.
I guess you have to run it twice because the first time you run it, the ActiveCell could be anything, and your loop depends on it not being empty to start with, but after the first run you have selected column B (and other things)...
Read this previous answer on avoiding the use of Select and Activate, it will make your code more robust: How to avoid using Select in Excel VBA macros
Revised Code
See the comments for details, here is a cleaner version of your code which should work first time / every time!
Sub m_Range_End_Method()
Dim col As Range
Dim rng As Range
Dim currentRow As Long
' Use a With block to 'Fully Qualify' the ranges to MySheet
With ThisWorkbook.Sheets("MySheet")
' Set col range to the intersection of used range and column B
Set col = Intersect(.UsedRange, .Columns("B"))
' Loop through cells in col to set description in each row
For Each rng In col
currentRow = rng.Row
' Check upper case value match against upper case string
If InStr(UCase(rng.Value), "PETROL") > 0 Then
.Cells(currentRow, 5) = "Shopping"
.Cells(currentRow, 6) = "Car"
End If
Next rng
End With
End Sub
I have an excel file like
Original File
I want to transform all the cells that filled with information into a single column. Like
To transform This
How to i do this ?
I searched in internet about that i found just only transform cells in a single row to a single cell. But i couldn't find anything like this. Can you help me about that
This is a bit of code I keep around for this kind of job. It assumes that the values in each row are contiguous, that is there are no blank cells inside the data set. It also assumes that you're on the sheet that contains the data when you trigger it, and that you want the data to be placed on a new worksheet.
Option Explicit
Sub Columnise()
Dim shtSource As Worksheet
Dim shtTarget As Worksheet
Dim rngRow As Range, rngCol As Range
Dim lCount As Long
Set shtSource = ActiveSheet 'Or specify a sheet using Sheets(<name>)
Set rngCol = Range("A1", Range("A" & Rows.Count).End(xlUp))
Set shtTarget = Sheets.Add 'Or specify a sheet using Sheets(<name>)
'Define starting row for the data
lCount = 1
'Loop through each row
For Each rngRow In rngCol
'On each row, loop through all cells until a blank is encountered
Do While rngRow.Value <> ""
'Copy the value to the target
shtTarget.Range("A" & lCount).Value = rngRow.Value
'Move one space to the right
Set rngRow = rngRow.Offset(0, 1)
'Increment counter
lCount = lCount + 1
Loop
Next rngRow
End Sub
You should end up with all the data in a single column on a new worksheet.
EDITED TO ADD: Since you mentioned your data does contain blank cells, it gets more complicated. We'll want to add a way to continue to the actual end of the data, rather than just looping until we hit a blank cell. We'll modify the Do While... condition to this:
Do While rngCell.Column <= Cells(rngCell.Row, Columns.Count).End(xlToLeft).Column
This will loop until the end of the data in the row, then move on. Give it a shot and let us know.
I can pull together a decent macro that does what I need but I forgot that the range will change everyday.
To be specific the row count will get higher.
Right now my macro goes through and hides any row that doesn't have today's date and then copies a set range to a worksheet in a different workbook.
The only problem I have is that range will change everyday, so I figure I need a way to copy only rows with data in them once the rest are hidden and then paste them to the other workbook.
Sub automate()
Dim cell As Range
For Each cell In Range("AB2:AB30000")
If cell.Value < Date And cell.Value <> Empty Then cell.EntireRow.Hidden = True
Next
Range("K28336:K28388,O28336:O28388,P28336:P28388,Q28336:Q28388,R28336:R28388,S28336:S28388,T28336:T28388,U28336:U28388,V28336:V28388,Y28336:Y28388,AA28336:AA28388,AB28336:AB28388").Select
Selection.Copy
Workbooks.Open ("\\gvwac09\Public\Parts\Test\2014 IPU.xlsx")
Sheets("Historical Data").Activate
ActiveSheet.Range("c1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteFormats
ActiveSheet.Paste
This is my macro so far. I'm sorry if I didn't format this post correctly, new to this.
I do not understand exacting what you are attempting but I believe I can give you some useful pointers.
I do not explain the statements I use in the code below. Look them up in the Visual Basic Editor's Help or try searching the web for "Excel VBA xxxxx". Come back with questions if necessary but the more you can discover for yourself, the quicker your skills will develop.
Firstly you need to find the last row containing data. Examining every row down to AB30000 just wastes time. Macro Demo1 below demonstrates two techniques. There are more techniques for finding the last row, none of which are appropriate in every situation. Search StackOverflow for "[excel-vba] find last row". There are lots of relevant questions and answers although the first technique I use is far and away the most popular.
General advice: If you can break your requirement down to a sequence of single issues (such as "find last row"), you will find it easier to search StackOverflow for an answer.
Always include Application.ScreenUpdating = False at the start of your macros if you are going to amend a worksheet. Without this statement, everytime you hide a row, Excel repaints the screen.
I have created some test data which I hope is representative of your data. I have two worksheets Source and Dest. Source contains the full set of data. I copy the selected rows to Dest.
I have used Auto Filter which will be much faster than your technique if it will give you the effect you seek. Play with Auto Filter from the keyboard. If you can get the effect you seek, turn on the Macro Recorder, use Auto Filter to get the selection you seek and switch the Macro Recorder off. Adjust the Macro Recorder's statements to remove Selection and replace the corresponding statements in Demo2.
The secret of Demo2 is Set Rng = .AutoFilter.Range.SpecialCells(xlCellTypeVisible) which sets Rng to the visible rows. If you cannot get Auto Filter to work as you wish and you decide to use your current technique to set uninteresting rows invisible, keep this statement to get the remaining rows. However, I think macro Demo3 uses a better technique.
Option Explicit
Sub demo1()
Dim ColLast As Long
Dim Rng As Range
Dim RowLast As Long
Application.ScreenUpdating = False
With Worksheets("Source")
' This searches up from the bottom of column AB for a cell with a value.
' It is the VBA equivalent of placing the cursor at the bottom of column AB
' and clicking Ctrl+Up.
RowLast = .Cells(Rows.Count, "AB").End(xlUp).Row
Debug.Print "Last row with value in column AB: " & RowLast
' This searches for the last cell with a value.
Set Rng = .Cells.Find(What:="*", After:=.Range("A1"), SearchDirection:=xlPrevious)
If Rng Is Nothing Then
' Worksheet is empty
Else
RowLast = Rng.Row
ColLast = Rng.Column
Debug.Print "Last cell with value is: (" & RowLast & ", " & ColLast & _
") = " & Replace(Rng.Address, "$", "")
End If
End With
End Sub
Sub Demo2()
Dim Rng As Range
Dim SearchDate As String
SearchDate = "14-May-14"
Application.ScreenUpdating = False
With Sheets("Source")
.Cells.AutoFilter
.Cells.AutoFilter Field:=28, Criteria1:=SearchDate
Set Rng = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
End With
' Rng.Address has a maximum length of a little under 256 characters.
' Rng holds the addresses of all the visible rows but you cannot display
' all those addresses in an easy manner. However, this is only to give
' you an idea of what is in Rng; the Copy statement below uses the full
' set of addresses.
Debug.Print "Visible rows: " & Rng.Address
Rng.Copy Worksheets("Dest").Range("A1")
End Sub
Sub Demo3()
Dim RngToBeCopied As Range
Dim RowCrnt As Long
Dim RowLast As Long
Dim SearchDate As Long
' Excel holds dates as integers and times as fractions.
SearchDate = CLng(DateValue("20 May 2014"))
With Worksheets("Source")
RowLast = .Cells(Rows.Count, "AB").End(xlUp).Row
' Include header row in range to be copied
Set RngToBeCopied = .Rows(1)
For RowCrnt = 2 To RowLast
If .Cells(RowCrnt, "AB").Value = SearchDate Then
Set RngToBeCopied = Union(RngToBeCopied, .Rows(RowCrnt))
End If
Next
End With
Debug.Print RngToBeCopied.Address
RngToBeCopied.Copy Worksheets("Dest").Range("A1")
End Sub