Hi All,
I wrote this macro but it seems to be duplicating the data. Could I get another pair of eyes to help me find the problem please? Thank you.
The output in column B is correct.
The output in column C is correct.
Column D is a duplicate of column C and what should be in Column D ends up in Column I.
Column E is correct but F through H are duplicates.
Column J should be in column F.
Example
A 1/2/2019 1/2/2019 424046 424046 1/2/2019 A 230924 $1,044.10
B 1/3/2019 1/3/2019 424089 424089 1/3/2019 B 230936 $717.13
C 1/3/2019 1/3/2019 424135 424135 1/3/2019 C 230937 $1,489.11
I wrote this macro but it seems to be duplicating the data. Could I get another pair of eyes to help me find the problem please? Thank you.
The output in column B is correct.
The output in column C is correct.
Column D is a duplicate of column C and what should be in Column D ends up in Column I.
Column E is correct but F through H are duplicates.
Column J should be in column F.
Example
A 1/2/2019 1/2/2019 424046 424046 1/2/2019 A 230924 $1,044.10
B 1/3/2019 1/3/2019 424089 424089 1/3/2019 B 230936 $717.13
C 1/3/2019 1/3/2019 424135 424135 1/3/2019 C 230937 $1,489.11
Code:
<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit; line-height: 12px;">Sub RangeCopyPaste()
Dim cell As Range
Dim NewRange As Range
Dim MyCount As Long
MyCount = 1
For Each cell In Worksheets("GL").Range("D1:D2000")
If cell.Value = "Computer Checks" Then
If MyCount = 1 Then Set NewRange = cell.Offset(0, 1)
Set NewRange = Application.Union(NewRange, cell.Offset(0, 1))
MyCount = MyCount + 1
End If
Next cell
'--> Copy NewRange from inactive sheet into active sheet
NewRange.Copy Destination:=ActiveSheet.Range("B3")
'--> Remove Duplicates
ActiveSheet.Range("B3:B2000").RemoveDuplicates
For Each cell In Worksheets("GL").Range("D1:D2000")
If cell.Value = "Computer Checks" Then
If MyCount = 1 Then Set NewRange = cell.Offset(0, -2)
Set NewRange = Application.Union(NewRange, cell.Offset(0, -2))
MyCount = MyCount + 1
End If
Next cell
'--> Copy NewRange from inactive sheet into active sheet
NewRange.Copy Destination:=ActiveSheet.Range("C3")
'--> Remove Duplicates
ActiveSheet.Range("C3:C2000").RemoveDuplicates
For Each cell In Worksheets("GL").Range("D1:D2000")
If cell.Value = "Computer Checks" Then
If MyCount = 1 Then Set NewRange = cell.Offset(0, 2)
Set NewRange = Application.Union(NewRange, cell.Offset(0, 2))
MyCount = MyCount + 1
End If
Next cell
'--> Copy NewRange from inactive sheet into active sheet
NewRange.Copy Destination:=ActiveSheet.Range("D3")
'--> Remove Duplicates
ActiveSheet.Range("D3:D2000").RemoveDuplicates
For Each cell In Worksheets("GL").Range("D1:D2000")
If cell.Value = "Computer Checks" Then
If MyCount = 1 Then Set NewRange = cell.Offset(0, -3)
Set NewRange = Application.Union(NewRange, cell.Offset(0, -3))
MyCount = MyCount + 1
End If
Next cell
'--> Copy NewRange from inactive sheet into active sheet
NewRange.Copy Destination:=ActiveSheet.Range("E3")
'--> Remove Duplicates
ActiveSheet.Range("E3:E2000").RemoveDuplicates
For Each cell In Worksheets("GL").Range("D1:D2000")
If cell.Value = "Computer Checks" Then
If MyCount = 1 Then Set NewRange = cell.Offset(0, 4)
Set NewRange = Application.Union(NewRange, cell.Offset(0, 4))
MyCount = MyCount + 1
End If
Next cell
'--> Copy NewRange from inactive sheet into active sheet
NewRange.Copy Destination:=ActiveSheet.Range("F3")
'--> Remove Duplicates
ActiveSheet.Range("F3:2000").RemoveDuplicates
End Sub</code>
Last edited by a moderator: