table to picture macro

[chobanne]

Hello all, i need a help to make this macro

I attached picture of example table which i want to copy and paste it to sheet 2 as a picture but with some rules.

The position of used cells in table could be changed when i input data, and It is important macro to apply the rules given bellow.

rule 1.

Macro wil find every single column without data and will hide it (in this example it is columns H I and J) The data in column will count only from row 8. Every column from A to S must be affected by the rule. so if some other column is without data it must be hiden too. if all columns have data there will be no hiding

rule 2.

Macro must automatically find last row with text, to make copy box. (in this example he must find row 18 because row 19 is empty and make copy box area A5:S18)

Rule 3

Macro will make thick outside borders around copy box (in example it would be around A5:S18) and then he will make copy and paste it in sheet 2 as a picture.

Rule 4

After making picture, macro will return to sheet 1 and what is the most important, table in sheet 1 must be exactly the same as it was, before starting macro. (no hiden columns, no outside borders)

I hope this is posible to make, i cant do it alone.
I do this in steps, 100 times a day, and i hope someone will help

This is how sheet1 looks before starting macro and after macro is finished.

Example.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1
2
3
4
5	N	WIND	Dimensions			d/b	cf,0	r	r/b	Yr	l	A	Ac	j	Yl	c	we	We	We'
6			d (-) [d1]	b (D) [d2]	l
7			[m]	[m]	[m]	[ - ]	[ - ]	[m]	[ - ]	[ - ]	[ - ]	[m²]	[m²]	[ - ]	[ - ]	[ - ]	[kN/m²]	[kN/m']	[kN/m']
8	op1	x	0.10	0.20	4.20	0.50	2.25				42.00			1.00	0.86	1.94	1.814	0.363
9	op12	y	0.20	0.10	4.20	2.00	2.00				70.00			1.00	0.86	1.72	1.612	0.161
10	3	y	0.10	0.20	4.20	0.50	2.00				42.00			1.00	0.86	1.72	1.612	0.322
11	4	x	0.10	0.20	4.20	0.50	1.80				21.00			1.00	0.78	1.40	1.319	0.264
12	op4	x		0.24	2.40		1.20				9.84			1.00	0.86	1.03	0.969	0.237
13	op2	x		0.24	2.40		1.20				9.84			1.00	0.86	1.03	1.216	0.297
14	7	x		0.24	2.40		1.20				9.84			1.00	0.86	1.03	1.216	0.297
15	8	x	1.00	2.00	3.00		2.30				2.00	1.39	4.50	0.31	0.94	2.16	1.183	0.296
16	9	x	1.00	2.00	3.00		2.30				2.00	1.39	4.50	0.31	0.94	2.16	2.547	1.183	0.296
17	10	x	0.10	0.20	4.20	0.50	1.80				21.00			1.00	0.78	1.40	1.654	0.331
18	11	x		0.24	2.40		1.20				9.84			1.00	0.86	1.03	1.216	0.297
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sheet1

this is how picture looks in sheet2

 

[John_w]

See if this macro works for you. Note that because your table starts in column A the macro temporarily inserts a new narrow column A so that the left border is visible.

Public Sub Copy_Table_As_Picture_To_Sheet()

    Dim table As Range
    Dim col As Range
    Dim hiddenColumns As Collection, hiddenColumn As Variant
    Dim outsideBorders As Collection, outsideBorder As Variant
    Dim edge As Variant
 
    Set hiddenColumns = New Collection
    Set outsideBorders = New Collection
 
    With Worksheets("Sheet1")
 
        Set table = .Range("A5").CurrentRegion
     
        'Insert temporary narrow column A to move table to the right so that left border is visible
     
        .Columns(1).Insert
        .Columns(1).ColumnWidth = 0.1
     
        'Save columns without data and hide them
        
        For Each col In table.Columns
            If WorksheetFunction.CountA(col.Offset(3).Resize(col.Rows.Count - 3)) = 0 Then 'Offset(3) to start count at row 8
                hiddenColumns.Add col.Column
                col.EntireColumn.Hidden = True
            End If
        Next

        'Save current outside borders weight and change to thick outside border
     
        For Each edge In Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)
            With table.Borders(edge)
                outsideBorders.Add .Weight, CStr(edge)
                .Weight = xlMedium
            End With
        Next
     
        'Copy table to Sheet2 as a picture.  Offset and Resize needed to enlarge copied range to include top and left borders
     
        table.Offset(-1, -1).Resize(table.Rows.Count + 1, table.Columns.Count + 1).CopyPicture xlScreen, xlBitmap
        With Worksheets("Sheet2")
            .Pictures.Delete
            .Range("A1").PasteSpecial
        End With

        'Unhide hidden columns
     
        For Each hiddenColumn In hiddenColumns
            .Cells(1, hiddenColumn).EntireColumn.Hidden = False
        Next
     
        'Restore outside borders
     
        For Each edge In Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)
            table.Borders(edge).Weight = outsideBorders(CStr(edge))
        Next
     
        'Delete temporary column A
     
        .Columns(1).Delete
     
    End With
 
End Sub

 

[chobanne]

Yes its looks like what i want, but there are some little problems.

1st - the table has one empty row above which i dont want to be seen. I presume you try to add narrow row above the table that the upper border could be seen, That row must be narrow too.
2nd - right border can't be seen at all so i think one more narrow row must be added there too.

 

[John_w]

Record a macro whilst inserting a narrow row to get the code for that and incorporate it into the macro.

Try adjusting the constants in the table.Offset line. The syntax is Offset(rowOffset, columnOffset) and Resize(numRows, numColumns), so Offset(-1, -1) is the row above the table and the column on the left of the table (the narrow column) and Resize(table.Rows.Count + 1, table.Columns.Count + 1) extends the table by 1 row and 1 column.