EVANWIT84
New Member
- Joined
- Sep 25, 2020
- Messages
- 22
- Office Version
- 365
- Platform
- Windows
- MacOS
- Mobile
Hi All,
I'm dealing with a matrix of data where I have accounts off to the far left and the data repeats and where there are empty cells I just want to shift the data up. My problem is that in Range P thru R can be blank and S thru V can also be blank at the same time. As a result, I receive a Run-Time Error 1004 since the copy/paste are not the same size. I have also stuggled to write an If Statement that would solve this so i'm back to the drawing board.
Lastly, once I have shifted all the data up then I will delete out un-needed rows and copy/paste into a new tab. This part I should be able to do on my own.
Sub GrabDataForEachAccount()
Dim x As Range
Dim xRange As Range
Dim amf As Worksheet
Dim ws As Worksheet
Dim rd As Worksheet
Dim Cal As Worksheet
Dim rdLastCell As Long
Dim FirstRow As Double
Dim LastRow As Double
Set ws = Sheets("Summary")
Set amf = Sheets("AMF")
Set Cal = Sheets("CalcSheet")
Set xRange = amf.Range("a2:a" & amf.Range("a1048567").End(xlUp).Row)
FirstRow = Cal.Range("P1", "P" & Rows.Count).End(xlDown).Row
LastRow = Cal.Range("P" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For Each x In xRange.Cells
ws.UsedRange.SpecialCells(xlCellTypeVisible).AutoFilter Field:=5, Criteria1:=x
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Sheets("CalcSheet").[a1]
Cal.Range("P" & FirstRow, "R" & LastRow).Copy Cal.Range("P2") 'I want this to Copy if >0 Values in Range
Cal.Range("AB" & FirstRow, "AB" & LastRow).Copy Cal.Range("AB2")
Cal.UsedRange.SpecialCells(xlCellTypeVisible).AutoFilter Field:=9, Criteria1:=">0"
Cal.UsedRange.SpecialCells(xlCellTypeVisible).Copy Sheets("Summary2").[a1]
'Delete unneeded rows
'Paste into new tab and add into bottom
Cal.Cells.Clear
Next
End Sub
I'm dealing with a matrix of data where I have accounts off to the far left and the data repeats and where there are empty cells I just want to shift the data up. My problem is that in Range P thru R can be blank and S thru V can also be blank at the same time. As a result, I receive a Run-Time Error 1004 since the copy/paste are not the same size. I have also stuggled to write an If Statement that would solve this so i'm back to the drawing board.
Lastly, once I have shifted all the data up then I will delete out un-needed rows and copy/paste into a new tab. This part I should be able to do on my own.
Sub GrabDataForEachAccount()
Dim x As Range
Dim xRange As Range
Dim amf As Worksheet
Dim ws As Worksheet
Dim rd As Worksheet
Dim Cal As Worksheet
Dim rdLastCell As Long
Dim FirstRow As Double
Dim LastRow As Double
Set ws = Sheets("Summary")
Set amf = Sheets("AMF")
Set Cal = Sheets("CalcSheet")
Set xRange = amf.Range("a2:a" & amf.Range("a1048567").End(xlUp).Row)
FirstRow = Cal.Range("P1", "P" & Rows.Count).End(xlDown).Row
LastRow = Cal.Range("P" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For Each x In xRange.Cells
ws.UsedRange.SpecialCells(xlCellTypeVisible).AutoFilter Field:=5, Criteria1:=x
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Sheets("CalcSheet").[a1]
Cal.Range("P" & FirstRow, "R" & LastRow).Copy Cal.Range("P2") 'I want this to Copy if >0 Values in Range
Cal.Range("AB" & FirstRow, "AB" & LastRow).Copy Cal.Range("AB2")
Cal.UsedRange.SpecialCells(xlCellTypeVisible).AutoFilter Field:=9, Criteria1:=">0"
Cal.UsedRange.SpecialCells(xlCellTypeVisible).Copy Sheets("Summary2").[a1]
'Delete unneeded rows
'Paste into new tab and add into bottom
Cal.Cells.Clear
Next
End Sub