Pasting issues using VBA - excel

wish you all the best.
I am making a code using VBA to find and detect errors from one sheet and paste the values from column A and B from the row of the error to the destination sheet.
my code is mostly working my issue is the content that is pasting which is the error cell and the next one to the right instead of the values from A and B (example: imagine macro is running all values in column K and there is an error in K85, it is pasting K85 and L85, instead of A85 and B85)
Sub Copy_NA_Values()
Dim rng As Range
Dim firstBlank As Range
Dim shtSource As Worksheet
Dim shtDestination As Worksheet
Set shtSource = ThisWorkbook.Sheets("JE Royalty detail") 'Change to the name of the source sheet
Set shtDestination = ThisWorkbook.Sheets("DB") 'Change to the name of the destination sheet
Set rng = shtSource.Range("F:F").SpecialCells(xlCellTypeFormulas, xlErrors)
For Each cell In rng
If IsError(Range("F:F")) = False Then
Set firstBlank = shtDestination.Range("K" & Rows.Count).End(xlUp).Offset(1, 0)
cell.Resize(1, 2).Copy firstBlank
End If
Next cell
End Sub
How can I make it so it will paste the correct cells i have tried to use paste special but I might've used it wrongly but I had errors, all help apreciated.
Have a good one.

it is pasting K85 and L85, instead of A85 and B85
Try replacing:
cell.Resize(1, 2).Copy firstBlank
with
shtSource.Range("A" & cell.Row & ":B" & cell.Row).Copy firstBlank
To paste only values, do this instead:
shtSource.Range("A" & cell.Row & ":B" & cell.Row).Copy
firstBlank.PasteSpecial (xlPasteValues)

Copy Values When Matching Error Values
Option Explicit
Sub BackupErrorValues()
Const SRC_NAME As String = "JE Royalty detail"
Const SRC_ERROR_RANGE As String = "F:F"
Const SRC_COPY_RANGE As String = "A:B"
Const DST_NAME As String = "DB"
Const DST_FIRST_CELL As String = "A2"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range
On Error Resume Next ' to prevent error if no error values
Set srg = Intersect(sws.UsedRange, sws.Columns(SRC_ERROR_RANGE)) _
.SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If srg Is Nothing Then
MsgBox "No cells with error values found.", vbExclamation
Exit Sub
End If
Set srg = Intersect(srg.EntireRow, sws.Range(SRC_COPY_RANGE))
Dim cCount As Long: cCount = srg.Columns.Count
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
If dws.FilterMode Then dws.ShowAllData ' prevent failure of 'Find' method
Dim dCell As Range
With dws.UsedRange
Set dCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
End With
If dCell Is Nothing Then
Set dCell = dws.Range(DST_FIRST_CELL)
Else
Set dCell = dws.Cells(dCell.Row + 1, dws.Range(DST_FIRST_CELL).Column)
End If
Dim drrg As Range: Set drrg = dCell.Resize(, cCount)
Dim sarg As Range, srCount As Long
For Each sarg In srg.Areas
srCount = sarg.Rows.Count
drrg.Resize(srCount).Value = sarg.Value
Set drrg = drrg.Offset(srCount)
Next sarg
MsgBox "Error rows backed up.", vbInformation
End Sub

Related

Copy from column A instead of column F?

I want to copy and paste columns from Sheet W2W to Sheet OTD Analysis when column F value doesn’t exist in OTD Analysis.
This code copied column F:AU instead of A:AU.
Sub Transfer()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Sheets("W2W").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundVal As Range
For Each rng In Sheets("W2W").Range("F2:F" & LastRow)
Set foundVal = Sheets("OTD Analysis").Range("F:F").Find(rng, LookIn:=xlValues, lookat:=xlWhole)
If foundVal Is Nothing Then
rng.Columns("A:AU").Copy
Sheets("OTD Analysis").Activate
b = Sheets("OTD Analysis").Cells(Rows.Count,1).End(xlUp).Row
Sheets("OTD Analysis").Cells(b + 1, 1).Select
ActiveSheet.Paste
End If
Next rng
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
You want Columns("A:AU") in reference to the entire row.
rng.EntireRow.Columns("A:AU").Copy
Transfer New Entries
Let's assume that rng is cell F2. Then
rng.Columns("A:AU") refers to the range F2:AZ2,
rng.EntireRow refers to the range A2:XFD2,
rng.EntireRow.Columns("A:AU") refers to the range A2:AU2.
Option Explicit
Sub TransferNewEntries()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source - to be read (copied) from
Dim sws As Worksheet: Set sws = wb.Worksheets("W2W")
Dim slRow As Long
slRow = sws.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
Dim srg As Range: Set srg = sws.Range("A2", sws.Cells(slRow, "AU"))
Dim scrg As Range: Set scrg = sws.Range("F2", sws.Cells(slRow, "F"))
' or e.g. just 'Set scrg = srg.Columns(6)'
' Destination - to be written (pasted) to
Dim dws As Worksheet: Set dws = wb.Worksheets("OTD Analysis")
Dim dlRow As Long
dlRow = dws.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
Dim dcrg As Range: Set dcrg = dws.Range("F2", dws.Cells(dlRow, "F"))
Dim surg As Range
Dim sCell As Range
Dim sr As Long
Dim drIndex As Variant
Dim drCount As Long
For Each sCell In scrg.Cells
sr = sr + 1 ' the n-th cell of the source column range...
' ... more importantly, the n-th row of the source range
drIndex = Application.Match(sCell.Value, dcrg, 0)
If IsError(drIndex) Then ' source value was not found
drCount = drCount + 1 ' count the rows to be copied
If surg Is Nothing Then ' combine the rows into a range...
Set surg = srg.Rows(sr)
Else
Set surg = Union(surg, srg.Rows(sr))
End If
'Else ' source value was found; do nothing
End If
Next sCell
If surg Is Nothing Then
MsgBox "No new entries (no action taken).", vbExclamation
Exit Sub
End If
Dim dfCell As Range: Set dfCell = dws.Cells(dlRow + 1, "A")
surg.Copy dfCell ' ... to be copied in one go
MsgBox "New entries copied: " & drCount, vbInformation
End Sub

Extract values from each cell to a separate sheet

I have a file with a few sheets, I need to extract values from each not empty cell into a column on another sheet.
Would be awesome if while doing that duplicates can be removed as well.
The following code infinitely loops. I don't see how to break the loop since all the events are being used in the body of the code.
Range where the cells are being looked for on both sheets are different, that is why I used .End(xlUp) to define the last row with values in cells.
I cannot use empty cells as a trigger for stopping the loop because there are empty cells between cells with values.
Sub updt()
Dim ws As Worksheet, currWs As Worksheet, Lng As Integer, rng As Range
Set ws = wb.Worksheets("Sheet1") 'the source sheet
Set currWs = Sheets("Sheet2") 'the destination sheet
Lng = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A2:A" & Lng)
For Each c Lng rng
If WorksheetFunction.CountIf(currWs.Range("A:A"), c.Value) = 0 Then
currWs.Range("A" & currWs.Cells(Rows.Count, 1).End(xlUp).Row)(2) = c.Value
End If
Next
End Sub
Update Column With Unique Non-Existing Values From a Column of Another Worksheet Using a Dictionary
To avoid further complications, no arrays are used.
Option Explicit
Sub UpdateWorksheet()
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet, calculate the last row
' and reference the source column range.
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim srg As Range: Set srg = sws.Range("A2:A" & slRow)
' Reference the destination worksheet and calculate the last row.
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row
' Define a dictionary (object).
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case-insensitive
' Declare variables.
Dim cCell As Range
Dim cKey As Variant
' Write the unique values from the destination column range
' to the dictionary.
If dlRow > 1 Then ' 1 means 'first row - 1' i.e. '2 - 1'
Dim drg As Range: Set drg = dws.Range("A2:A" & dlRow)
For Each cCell In drg.Cells
cKey = cCell.Value
If Not IsError(cKey) Then ' exclude error values
If Len(cKey) > 0 Then ' exclude blanks
dict(cKey) = Empty
End If
End If
Next cCell
End If
' Add the unique values from the source column range
' to the dictionary.
For Each cCell In srg.Cells
cKey = cCell.Value
If Not IsError(cKey) Then ' exclude error values
If Len(cKey) > 0 Then ' exclude blanks
dict(cKey) = Empty
End If
End If
Next cCell
' Check if the dictionary is empty.
If dict.Count = 0 Then
MsgBox "No valid values found.", vbCritical
Exit Sub
End If
' Clear the previous values from the destination first cell to the bottom
' of the worksheet.
Dim dCell As Range: Set dCell = dws.Range("A2")
With dCell
.Resize(dws.Rows.Count - .Row + 1).ClearContents
End With
' Write the unique values from the dictionary to the destination worksheet.
For Each cKey In dict.Keys
dCell.Value = cKey ' write
Set dCell = dCell.Offset(1) ' reference the cell below
Next cKey
' Inform.
MsgBox "Worksheet updated.", vbInformation
End Sub
You might want to use AdvancedFilter:
Option Explicit
Sub Copy_Advanced()
Dim ws As Worksheet, currWs As Worksheet, Lng As Integer, rng As Range
Set ws = Worksheets("Sheet1") 'the source sheet
Set currWs = Sheets("Sheet2") 'the destination sheet
Lng = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A1:A" & Lng)
ws.Range("D1").Value = ws.Range("A1").Value
ws.Range("D2") = ">0"
ws.Range(rng.Address).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ws.Range("D1:D2"), _
CopyToRange:=currWs.Range("A1"), _
Unique:=True
End Sub

How to highlight matched values from two different ranges and worksheets?

I would like to highlight matching values in two different ranges and worksheets using VBA.
Worksheet #1 is named "OVR" with the range S2:V100 (where the highlighted values should show).
Worksheet #2 is named "LS" with the range A2:A101 containing a list of names.
My goal is to highlight all the cells in the range S2:V100 (from the "OVR" worksheet) that have a match with one of the cells in the range A2:A101 (from the "LS" worksheet).
I would like to integrate it to existing VBA for this file.
Sub FindReference()
LR1 = Worksheets("LS").Cells(Rows.Count, "A").End(xlUp).Row
LR2 = Worksheets("OVR").Cells(Rows.Count, "A").End(xlUp).Row
Set rng1 = Worksheets("LS").Range("A2:A101" & LR1)
Set rng2 = Worksheets("OVR").Range("S2:V100" & LR1)
For Each rCell In rng1
rCell.Interior.ColorIndex = xlNone
rCell.Validation.Delete
result = WorksheetFunction.CountIf(rng2, rCell)
If result > 0 Then rCell.Interior.Color = vbGreen
Next
End Sub
Color Matching Cells
Option Explicit
Sub FindReference()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim lRow As Long
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets("LS")
lRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim srg As Range: Set srg = sws.Range("A2:A" & lRow)
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("OVR")
lRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row
Dim drg As Range: Set drg = dws.Range("S2:V" & lRow)
' Combine matching cells.
Dim durg As Range
Dim dCell As Range
Dim dValue As Variant
For Each dCell In drg.Cells
dValue = dCell.Value
If Not IsError(dValue) Then
If Len(dValue) > 0 Then
If IsNumeric(Application.Match(dValue, srg, 0)) Then
If durg Is Nothing Then
Set durg = dCell
Else
Set durg = Union(durg, dCell)
End If
End If
End If
End If
Next dCell
' Color matching cells.
drg.Interior.ColorIndex = xlNone
drg.Validation.Delete
If Not durg Is Nothing Then
durg.Interior.Color = vbGreen
End If
' Inform.
MsgBox "Data highlighted.", vbInformation
End Sub

Copy data from multiple sheet and paste into 1 sheet

I am trying to copy data from multiple sheets and paste it into Sheet1. The result paste it into Sheet1 but the same row each time and not the next row of previous copied data. Here is my code. Any help is really appreciate. Thank you!
Sub LoopCopySheetsData()
Dim i As Integer
Dim wb As Workbook
Dim totalWS As Long
Set wb = ActiveWorkbook
'totalWS = wb.Sheets.Count
totalWS = 4
For i = 2 To totalWS 'Start of the VBA loop
If i < totalWS + 1 Then
Sheets(i).Select
With wb.Sheets(i)
Set findHeadRow = .Range("A:A").Find(What:="Data", LookIn:=xlValues)
End With
headRow = findHeadRow.Row
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Sheets(i).Range("A" & headRow + 1 & ":A" & lastRow).Copy
Range("A1").Activate
With wb.Sheets("Sheet1")
lastRowMaster = Cells(Rows.Count, "D").End(xlUp).Row
Sheets("Sheet1").Range("D" & lastRowMaster + 1).PasteSpecial xlPasteValues
End With
End If
Next i
End Sub
Copy Columns From Multiple Worksheets
If the header cell (Data) contains a formula, you will have to use xlValues instead of xlFormulas (first occurrence).
Adjust the values in the constants section.
Option Explicit
Sub LoopCopySheetsData()
' Source
Const sCol As String = "A"
Const sHeader As String = "Data"
' Destination
Const dName As String = "Sheet1"
Const dCol As String = "D"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range
Set dfCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Offset(1)
Dim sws As Worksheet
Dim srg As Range ' Range
Dim shCell As Range ' Header Cell
Dim slCell As Range ' Last Cell
Dim rCount As Long ' Source/Destination Rows Count
For Each sws In wb.Worksheets
If StrComp(sws.Name, dName, vbTextCompare) <> 0 Then ' exclude 'dws'
' Find header cell and last cell.
With sws.Columns(sCol)
Set shCell = _
.Find(sHeader, .Cells(.Cells.Count), xlFormulas, xlWhole)
Set slCell = .Find("*", , xlFormulas, , , xlPrevious)
End With
If Not shCell Is Nothing Then
If Not slCell Is Nothing Then
rCount = slCell.Row - shCell.Row ' without header
If rCount > 0 Then
Set srg = shCell.Offset(1).Resize(rCount)
dfCell.Resize(rCount).Value = srg.Value ' copy
Set dfCell = dfCell.Offset(rCount) ' next
End If
End If
End If
End If
Next sws
MsgBox "Done.", vbInformation
End Sub
Please heed this post: How to avoid using Select in Excel VBA. As second answer mentions, avoid any use of ActiveWorkbook, Activate, and Select for efficiency, maintenance, and readability.
Instead, explicitly qualify all Workbook, Worksheet, Cells, Range, and other objects. In fact, consider range assignment and avoid the need of copy and paste:
Sub LoopCopySheetsData()
Dim i As Integer, totalWS As Integer
Dim headRow As Long, lastRow As Long, headRowMaster As Long, lastRowMaster As Long
'totalWS = ThisWorkbook.Sheets.Count
totalWS = 4
For i = 2 To totalWS
If i < (totalWS + 1) Then
With ThisWorkbook.Sheets(i)
headRow = .Range("A:A").Find(What:="Data", LookIn:=xlValues).Row
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With ThisWorkbook.Sheets("Sheet1")
headRowMaster = .Cells(.Rows.Count, "D").End(xlUp).Row
lastRowMaster = headRowMaster + (lastRow - headRow)
' ASSIGN VALUES BY RANGE
.Range("D" & headRowMaster + 1 & ":D" & lastRowMaster).Value = _
ThisWorkbook.Sheets(i).Range("A" & headRow + 1 & ":A" & lastRow).Value
End With
End If
Next i
End Sub

Search for not empty cells in range, paste to new sheet

In Excel I'm looking for a VBA macro to do the following:
Search "Sheet2" range A2:Q3500 for any cells containing data (not empty), and copy only those cells.
Paste those cells' exact values into "Sheet3" starting with cell A2.
When I say "exact value" I just mean text/number in the cell is exactly the same as it appeared when copied, no different formatting applied.
Any guidance would be super appreciated, thank you!
Copy Filtered Data
The following will copy the complete table range and then delete the 'empty' rows.
Adjust the values in the constants section.
Option Explicit
Sub CopyFilterData()
' Source
Const sName As String = "Sheet2"
Const sFirst As String = "A1"
' Destination
Const dName As String = "Sheet3"
Const dFirst As String = "A1"
Const dfField As Long = 1
Const dfCriteria As String = "="
' Both
Const Cols As String = "A:Q"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
If sws.AutoFilterMode Then sws.AutoFilterMode = False
Dim sfCell As Range: Set sfCell = sws.Range(sFirst)
Dim slCell As Range
With sfCell.Resize(sws.Rows.Count - sfCell.Row + 1)
Set slCell = .Find("*", , xlFormulas, , , xlPrevious)
End With
If slCell Is Nothing Then Exit Sub ' no data in column range
Dim rCount As Long: rCount = slCell.Row - sfCell.Row + 1
If rCount = 1 Then Exit Sub ' only headers
Dim scrg As Range: Set scrg = sfCell.Resize(rCount) ' Criteria Column Range
Dim srg As Range: Set srg = scrg.EntireRow.Columns(Cols) ' Table Range
Dim cCount As Long: cCount = srg.Columns.Count
Application.ScreenUpdating = False
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
If dws.AutoFilterMode Then dws.AutoFilterMode = False
dws.UsedRange.Clear
Dim dfcell As Range: Set dfcell = dws.Range(dFirst)
Dim drg As Range: Set drg = dfcell.Resize(rCount, cCount) ' Table Range
srg.Copy drg ' copy
Dim ddrg As Range: Set ddrg = drg.Resize(rCount - 1).Offset(1) ' Data Range
drg.AutoFilter dfField, dfCriteria
Dim ddfrg As Range ' Data Filtered Range
On Error Resume Next
Set ddfrg = ddrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
dws.AutoFilterMode = False
If Not ddfrg Is Nothing Then
ddfrg.EntireRow.Delete ' delete 'empty' rows
End If
'drg.EntireColumn.AutoFit
'wb.Save
Application.ScreenUpdating = True
MsgBox "Data copied.", vbInformation, "Copy Filtered Data"
End Sub
The code below should help you.
Sub CopyNonEmptyData()
Dim intSheet3Row As Integer
intSheet3Row = 2
For Each c In Range("A2:Q3500")
If c.Value <> "" Then
Sheets("Sheet3").Range("A" & intSheet3Row).Value = c.Value
intSheet3Row = intSheet3Row + 1
End If
Next c
End Sub

Resources