Macros to copy only rows with data

[toncho]

Hello everyone.

I understand that many times same question popup, and I read and tried most of the suggested macros, but nothing seem to work out on my sheet.

I want to copy from sheet 1 range P3:R54 only the rows with data, without the blank rows, to sheet 2, Range B3, paste value with cells border format.

I will appreciate any ideas.

 

[Joe4]

Welcome to the Board!

We have no idea what your data looks like, so have to make a bunch of assumptions (in these cases, it is often helpful to post a small sampling of your data and your expected output).

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

Making some assumptions (that if column P is blank, so are columns Q and R), and a few others, here is some VBA code that may do what you want:

Sub MyCopy()

    Dim lr As Long
   
    Sheets("Sheet1").Activate
   
'   Find last row in column P with data
    If Range("P54") <> "" Then
        lr = 54
    Else
        lr = Range("P54").End(xlUp).Row
    End If
   
'   Copy data
    Range("P3:R" & lr).SpecialCells(xlCellTypeConstants, 23).Copy Sheets("Sheet2").Range("B3")
   
'   Put border around pasted range
    Sheets("Sheet2").Activate
    Range("B3").CurrentRegion.Select
       
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
   
End Sub

 

[toncho]

tournaments.xlsm
	P	Q	R
3	Бургас / 14г. / държавно	07/Jan/2022	13/Jan/2022
4
5	DUBAI BAWL	17/Jan/2022	23/Jan/2022
6
7
8
9
10
11
12
13
14
15
16
17
18
19	BUL / unknown / Category 3	25/Apr/2022	01/May/2022
20
21
22
23
24
25
26
27	KIM CLIJSTERS	20/Jun/2022	26/Jun/2022
28
tournaments

Cell Formulas
Range	Formula
P3:P28	P3	=IF(D3<>"",E3,IF(H3<>"",I3,IF(L3<>"",M3,"")))
Q3:Q28	Q3	=IF(D3<>"",F3,IF(H3<>"",J3,IF(L3<>"",N3,"")))
R3:R28	R3	=IF(D3<>"",G3,IF(H3<>"",K3,IF(L3<>"",O3,"")))

 

[toncho]

Hello Joe4,

Thank you for the effort. I posted above the mini sheet.

What I want to do is to take only non-blank rows and arrange them in a new table.

 

[toncho]

`

Welcome to the Board!

We have no idea what your data looks like, so have to make a bunch of assumptions (in these cases, it is often helpful to post a small sampling of your data and your expected output).

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

Making some assumptions (that if column P is blank, so are columns Q and R), and a few others, here is some VBA code that may do what you want:

Sub MyCopy()

    Dim lr As Long
  
    Sheets("Sheet1").Activate
  
'   Find last row in column P with data
    If Range("P54") <> "" Then
        lr = 54
    Else
        lr = Range("P54").End(xlUp).Row
    End If
  
'   Copy data
    Range("P3:R" & lr).SpecialCells(xlCellTypeConstants, 23).Copy Sheets("Sheet2").Range("B3")
  
'   Put border around pasted range
    Sheets("Sheet2").Activate
    Range("B3").CurrentRegion.Select
      
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
  
End Sub

Hello Joe4,

I tried above macro, but it does not work as I want. I posted mini sheet, could you give is another try?

thanks

 

[toncho]

`

Hello Joe4,

I tried above macro, but it does not work as I want. I posted mini sheet, could you give is another try?

thanks

Hello Joe4,

I found a solution with another transition sheet and quite a few time of recording Macros:

Sub table()
'
'Clearing the old data
'
Sheets("schedule").Select
Rows("6:73").Select
Selection.Delete Shift:=xlUp
'
'Copy the data
'
Sheets("tournaments").Select
Range("P2:R54").Select
Selection.copy
'
'Filter the non blank
'
Sheets("prehod").Visible = True
Sheets("prehod").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("$A$1:$C$53").AutoFilter Field:=1, Criteria1:="<>"
Range("A1:C25").Select
Selection.copy
Sheets("prehod").Select
ActiveWindow.SelectedSheets.Visible = False
'
'Paste the data and format the cells
'
Sheets("schedule").Select
Range("B6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("C6:D61").Select
Selection.NumberFormat = "dd/mmm/yyyy"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("B6").Select
End Sub