Make Table and card from sheets menu

VBA & Macros

Last Post by BANDI MAHA 3 years ago

3 Posts

2 Users

0 Reactions

11 Views

RSS

BANDI MAHA

(@bandikukargmail-com)

Posts: 23

Eminent Member

Topic starter

Hi admin ...

can you help me, make code macros based on the menu sheets.

when you click send in the sheets menu, the data in the sheets menu is automatically copied to the sheets table and sheets card like the example I've created manually...

thank you for your attention... I really hope that I can answer it directly on the file I sent

By Bandi

Posted : 15/10/2021 8:38 am

Catalin Bombea

(@catalinb)

Posts: 1937

Member Admin

Here is the code used in the sample file attached:

Option Explicit

Sub TransferData()
Dim tbl1 As ListObject, tbl2 As ListObject, Card As Worksheet
Set tbl1 = ThisWorkbook.Worksheets("Table").ListObjects("Table1")
Set tbl2 = ThisWorkbook.Worksheets("Menu").ListObjects("Table2")
Set Card = ThisWorkbook.Worksheets("Card")
If tbl2.DataBodyRange Is Nothing Then Exit Sub

Dim NewRow As ListRow
tbl1.ListRows.Add
Set NewRow = tbl1.ListRows(tbl1.ListRows.Count)
NewRow.Range.Cells(tbl1.ListColumns("Kode").Index).Resize(tbl2.ListRows.Count, tbl2.ListColumns.Count).Value = tbl2.DataBodyRange.Value

'build card
Dim LastRow As Long, Rw As Long, Col As Long
On Error Resume Next
LastRow = Card.Cells.Find("*", Card.Cells(1), , , xlByRows, xlPrevious).Row
If Err.Number <> 0 Then LastRow = 0
On Error GoTo 0

Card.Columns(1).ColumnWidth = 1
Card.Columns(2).ColumnWidth = 35
Card.Columns(3).ColumnWidth = 1
Card.Columns(4).ColumnWidth = 35
Card.Columns(5).ColumnWidth = 1
Card.Columns(6).ColumnWidth = 35

'identify first empty column
Col = 2

If LastRow > 0 Then
If Len(Card.Cells(LastRow, 6).Value) = 0 Then Col = 6
If Len(Card.Cells(LastRow, 4).Value) = 0 Then Col = 4
If Col > 2 Then LastRow = LastRow - 7
End If

Dim i As Long
For i = 1 To tbl2.ListRows.Count
DoEvents
Card.Cells(LastRow + 1, 1).RowHeight = 8

Card.Cells(LastRow + 2, Col).Value = "Green Officer"
Card.Cells(LastRow + 3, Col).Value = tbl2.ListRows(i).Range.Cells(tbl2.ListColumns("Kode").Index).Value
Card.Cells(LastRow + 4, Col).Value = "Green Fruits"
Card.Cells(LastRow + 5, Col).Value = "name: " & tbl2.ListRows(i).Range.Cells(tbl2.ListColumns("Name").Index).Value
Card.Cells(LastRow + 6, Col).Value = "Room: " & tbl2.ListRows(i).Range.Cells(tbl2.ListColumns("Room").Index).Value
Card.Cells(LastRow + 7, Col).Value = "Pembelian/ Hibah: " & tbl2.ListRows(i).Range.Cells(tbl2.ListColumns("Pembelian").Index).Value

FormatRange Card.Range(Card.Cells(LastRow + 2, Col), Card.Cells(LastRow + 3, Col))
FormatRange Card.Range(Card.Cells(LastRow + 4, Col), Card.Cells(LastRow + 7, Col))

Dim Img As Shape, ImgCopy As Shape
Set Img = tbl2.Parent.Shapes("Green Fruits")
Img.Copy
Card.Cells(LastRow + 2, 2).PasteSpecial
Set ImgCopy = Card.Shapes(Card.Shapes.Count)
ImgCopy.Top = Card.Cells(LastRow + 2, Col).Top + 2
ImgCopy.Left = Card.Cells(LastRow + 2, Col).Left + 4

Col = Col + 2
If Col > 6 Then 'move to a new row
Col = 2
LastRow = LastRow + 7
End If

Next i
Application.Goto Card.Cells(LastRow + 2, Col)
tbl2.DataBodyRange.Delete

End Sub

Sub FormatRange(ByVal Rng As Range)

With Rng
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlMedium
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With