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
Related
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
Not had idea what the root cause for the error it only occur when the program try to find the value in array at the third value.
Public Sub GetBGA()
Dim PMIC() As String
Dim PartNumber1 As Long
Dim Counter As Long
Worksheets("Test1").Select
PartNumber1 = Range("A1", Range("A1").End(xlDown)).Cells.Count
ReDim PMIC(1 To PartNumber1)
For Counter = 1 To PartNumber1
PMIC(Counter) = Range("A1").Offset(Counter - 1, 0).Value
Next Counter
For Counter = 1 To PartNumber1
Worksheets("Test2").Select
Cell.Find(What:=PMIC(Counter), After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.EntireRow.Copy
Worksheets("Test3").Select
Rows(1).Insert
Next Counter
End Sub
Copy Matching Rows
Option Explicit
Sub GetBGA()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Lookup
Dim lws As Worksheet: Set lws = wb.Worksheets("Test1")
Dim lfCell As Range: Set lfCell = lws.Range("A1")
Dim llCell As Range: Set llCell = lws.Cells(lws.Rows.Count, "A").End(xlUp)
Dim lrg As Range: Set lrg = lws.Range(lfCell, llCell)
Dim lrCount As Long: lrCount = lrg.Rows.Count
Dim lData() As Variant
If lrCount = 1 Then
ReDim lData(1 To 1, 1 To 1): lData(1, 1) = lrg.Value
Else
lData = lrg.Value
End If
' Source (don't you know the column?)
Dim sws As Worksheet: Set sws = wb.Worksheets("Test2")
Dim srg As Range
Dim slCell As Range
With sws.UsedRange
Set slCell = .Cells(.Rows.Count, .Columns.Count)
Set srg = sws.Range("A1", slCell)
End With
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("Test3")
Dim drrg As Range: Set drrg = dws.Range("A1").Resize(, srg.Columns.Count)
' Loop (are you sure about 'xlPart' and '.Insert'?).
Application.ScreenUpdating = False
Dim lr As Long
Dim srrg As Range
Dim sCell As Range
For lr = lrCount To 1 Step -1 ' switch order with 'For lr = 1 To lrCount'
Set sCell = srg.Find(lData(lr, 1), slCell, xlFormulas, xlPart, xlByRows)
If Not sCell Is Nothing Then
Set srrg = srg.Rows(sCell.Row)
srrg.Copy
drrg.Insert
End If
Next lr
Application.ScreenUpdating = True
' Inform.
MsgBox "Data copied.", vbInformation
End Sub
I have a code to copy paste all rows which met condition, but how to copy not all rows but specific cells from those rows? For example just A, C and D cells from row.
Sub CopyRow_Item()
Application.ScreenUpdating = False
Dim LastRow As Long
Dim last_row As Long
Item = ThisWorkbook.Sheets("Sheet1").Range("B1").Value
LastRow = Sheets("Actuals").Cells.Find("*", SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row
last_row = Cells(Rows.Count, "A").End(xlUp).Row
Dim x As Long
x = 1
Dim rng As Range
For Each rng In Sheets("Actuals").Range("A2:A" & LastRow)
If rng = Item Then
rng.EntireRow.Copy
Sheets("Sheet1").Cells(last_row + x, 1).PasteSpecial xlPasteValues
x = x + 1
End If
Next rng
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Copy Non-Contiguous Rows
'*** marks the spots.
Option Explicit
Sub CopyRow_Item()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Actuals")
Dim slrCell As Range: Set slrCell = sws.Cells _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If slrCell Is Nothing Then Exit Sub ' no data
Dim srg As Range: Set srg = sws.Range("A2:A" & slrCell.Row)
Dim svrg As Range: Set svrg = sws.Range("A:A,B:B,D:D") '***
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1")
Dim Criterion As Variant: Criterion = dws.Range("B1").Value
Dim dCell As Range: Set dCell = dws.Columns("A") _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If dCell Is Nothing Then
Set dCell = dws.Range("A2")
Else
Set dCell = dCell.Offset(1)
End If
Application.ScreenUpdating = False
Dim sCell As Range
For Each sCell In srg.Cells
If sCell.Value = Criterion Then
Intersect(sCell.EntireRow, svrg).Copy '***
dCell.PasteSpecial xlPasteValues
Set dCell = dCell.Offset(1)
End If
Next sCell
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
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
Below code match the string in the specific range (this range contains Headers) if finds then copy the whole column and paste into Sheet2.
I want to add two more condition in below code that are:
Dim FindValue2 As String
Dim FindValue3 As String
FindValue2 = shSummary.Range("A2").Value
FindValue3 = shSummary.Range("B2").Value
and match in Sheet1 Column A for FindValue3 and Column F for FindValue2 after matching these 3 criteria then copy and paste the data.
Your help will be much appreciated.
Sub find()
Dim foundRng As Range
Dim FindValue As String
Dim lastRow As Long
Set shData = Worksheets("Sheet1")
Set shSummary = Worksheets("Sheet2")
FindValue = shSummary.Range("C2")
Set foundRng = shData.Range("G1:Z1").find(FindValue)
With shData
lastRow = .Cells(.Rows.Count, foundRng.Column).End(xlUp).Row
End With
shData.Rows("2:" & lastRow).Columns(foundRng.Column).Copy shSummary.Range("I3")
End Sub
Apply a filter to columns A and F then copy the visible cells.
Option Explicit
Sub Find3()
Dim wb As Workbook, wsData As Worksheet, wsSummary As Worksheet
Dim rngFound As Range, rngData As Range, rngCopy As Range
Dim FindValue As String, FilterA As String, FilterF As String
Dim lastRow As Long, c As Long
Set wb = ThisWorkbook
Set wsData = wb.Worksheets("Sheet1")
wsData.AutoFilterMode = False
Set wsSummary = wb.Worksheets("Sheet2")
With wsSummary
FindValue = .Range("B2")
FilterA = .Range("C2")
FilterF = .Range("A2")
End With
Set rngFound = wsData.Range("G1:Z1").find(FindValue)
If rngFound Is Nothing Then
MsgBox "'" & FindValue & "' not found", vbCritical
Exit Sub
End If
' column matching FindValue
c = rngFound.Column
lastRow = wsData.Cells(Rows.Count, c).End(xlUp).Row
If lastRow = 1 Then
MsgBox "No data in column " & c, vbCritical
Exit Sub
End If
' filter data on colA and F
With wsData
Set rngData = .Cells(2, c).Resize(lastRow - 1)
.UsedRange.AutoFilter
.UsedRange.AutoFilter Field:=1, Criteria1:=FilterA
.UsedRange.AutoFilter Field:=6, Criteria1:=FilterF
' data to copy
On Error Resume Next
Set rngCopy = rngData.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' copy data
If rngCopy Is Nothing Then
MsgBox "No data to copy from column " & c, vbCritical
.AutoFilterMode = False
Exit Sub
Else
rngCopy.Copy wsSummary.Range("I3")
End If
.AutoFilterMode = False
End With
MsgBox "Done"
End Sub
Copy Data Columns to Another Worksheet
Adjust the values in the constants section.
Delete (out-comment) the Debug.Print lines when done testing.
Option Explicit
Sub ExportDataColumns()
Const sName As String = "Sheet1"
Const sHeadersAddress As String = "G1:Z1"
Const dName As String = "Sheet2"
Const dReadList As String = "A2,B2,C2"
Const dWriteList As String = "F3,A3,I3"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim wsrCount As Long: wsrCount = sws.Rows.Count
Dim shrg As Range: Set shrg = sws.Range(sHeadersAddress)
Debug.Print "Source Header Range: " & shrg.Address(0, 0)
Dim sfRow As Long: sfRow = shrg.Row + 1 ' first row below the headers
Debug.Print "Source First Row: " & sfRow
If sfRow >= wsrCount Then Exit Sub
Dim slRow As Long: slRow = GetLastRow(shrg)
Debug.Print "Source Last Row: " & slRow
If slRow < sfRow Then Exit Sub
Dim sdrg As Range
Set sdrg = shrg.Resize(slRow - sfRow + 1).Offset(1)
Debug.Print "Source Data Range: " & sdrg.Address(0, 0)
Dim dRead() As String: dRead = Split(dReadList, ",")
Dim dWrite() As String: dWrite = Split(dWriteList, ",")
Dim dUpper As Long: dUpper = UBound(dRead)
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim srg As Range
Dim drg As Range
Dim dcrg As Range
Dim srCount As Long
Dim n As Long
For n = 0 To dUpper
Debug.Print "Item " & n + 1
Dim scIndex As Variant
scIndex = Application.Match(dws.Range(dRead(n)).Value, shrg, 0)
If IsNumeric(scIndex) Then
Set srg = sdrg.Columns(scIndex)
Debug.Print "Source Range: " & srg.Address(0, 0)
srCount = srg.Rows.Count
Set drg = dws.Range(dWrite(n)).Resize(srCount)
Debug.Print "Destination Range: " & drg.Address(0, 0)
drg.Value = srg.Value
Set dcrg = drg.Resize(wsrCount - drg.Row - srCount + 1) _
.Offset(srCount)
Debug.Print "Destination Clear Range: " & dcrg.Address(0, 0)
dcrg.ClearContents
End If
Next n
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the worksheet row number of the last non-empty row
' in the range from the first row of a range ('rg')
' through the same sized bottom-most row of the worksheet.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetLastRow( _
ByVal rg As Range) _
As Long
If rg Is Nothing Then Exit Function
Dim lCell As Range
With rg.Rows(1)
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
End With
If lCell Is Nothing Then Exit Function
GetLastRow = lCell.Row
End Function