I'm trying to build a macro that will move a table (group of cells) for me to another area of the excel spreadsheet. I've currently built this (this is the relevant part of code), but it only works with one table, as I coded it based on location of the first table. However, some of my spreadsheets have more tables, of differing locations (all the tables are stacked on top of each other, but have differing heights -- so I can't easily do what I've already done for the first table).
So my question is -- is there a way to code VBA to recognize the top left corner of each table (the data in the top left corner is always the same with each table) and then detect when the table (data) end both to the right and bottom of that top left corner, and then move all that?
I'm very new to this, and honestly am proud of my shabby "coding" below. Any help would be appreciated. I thought about using an "If..Then" statement for the detecting of the top left corner but have no idea how to go from there. Thank you for any help.
' Moving data and headers
Worksheets("Inventory").Range("E6:E14").Cut Worksheets("Inventory").Range("A1:A9")
Worksheets("Inventory").Range("F6:F14").Cut Worksheets("Inventory").Range("B1:B9")
Worksheets("Inventory").Range("G6:G14").Cut Worksheets("Inventory").Range("C1:C9")
Worksheets("Inventory").Range("H8:H14").Cut Worksheets("Inventory").Range("D3:D9")
Worksheets("Inventory").Range("I8:I14").Cut Worksheets("Inventory").Range("E3:E9")
Worksheets("Inventory").Range("J8:J14").Cut Worksheets("Inventory").Range("F3:F9")
Worksheets("Inventory").Range("K8:K14").Cut Worksheets("Inventory").Range("G3:G9")
Worksheets("Inventory").Range("L8:L14").Cut Worksheets("Inventory").Range("H3:H9")
Worksheets("Inventory").Range("M8:M14").Cut Worksheets("Inventory").Range("I3:I9")
' Merging and putting in Days Worked
Range("D1:I1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Sample Table:
If you have a rectangular range, then to find its upper left-hand corner and lower right-hand corner:
Sub CornerFinder(RR As Range)
Dim addy1 As String, addy2 As String
addy1 = RR(1).Address(0, 0)
Dim nLastRow As Long, nLastColumn As Long
nLastRow = RR.Rows.Count + RR.Row - 1
nLastColumn = RR.Columns.Count + RR.Column - 1
addy2 = Cells(nLastRow, nLastColumn).Address(0, 0)
MsgBox addy1 & vbCrLf & addy2
End Sub
Tested with:
Sub MAIN()
Dim r As Range
Set r = Range("B9:J37")
Call CornerFinder(r)
End Sub
Ok based on your sample data and sample code, try this out.
Sub Test()
Const tlh As String = "Credited in Report"
With Sheets("Sheet1") 'Change to suit
Dim tl As Range, bl As Range
Dim first_add As String, tbl_loc As Variant
Set tl = .Cells.Find(tlh)
If Not tl Is Nothing Then
first_add = tl.Address
Else
MsgBox "Table does not exist.": Exit Sub
End If
Do
If Not IsArray(tbl_loc) Then
tbl_loc = Array(tl.Address)
Else
ReDim Preserve tbl_loc(UBound(tbl_loc) + 1)
tbl_loc(UBound(tbl_loc)) = tl.Address
End If
Set tl = .Cells.FindNext(tl)
Loop While tl.Address <> first_add
Dim i As Long, lrow As Long, tb_cnt As Long: tb_cnt = 0
For i = LBound(tbl_loc) To UBound(tbl_loc)
Set bl = .Cells.Find(vbNullString, .Range(tbl_loc(i)) _
, , , xlByColumns, xlNext)
lrow = Sheets("Sheet2").Range("A" & _
Sheets("Sheet2").Rows.Count).End(xlUp).Row
.Range(.Range(tbl_loc(i)).Offset(IIf(tb_cnt <> 0, 1, 0), 0), _
bl.Offset(-1, 0)).Resize(, 9).Copy _
Sheets("Sheet2").Range("A" & lrow).Offset(IIf(lrow = 1, 0, 1), 0)
tb_cnt = tb_cnt + 1
Set bl = Nothing
Next
End With
End Sub
This consolidates the data in one table.
I used copy instead of cut to be safe. You can change it whatever suits you.
I also use another sheet for the output since I'm using copy.
For example you have below in Sheet1:
It will be consolidated in Sheet2 like this:
Is this what you're trying? If not, you can go ahead and learn from the code.
Then once you do, adjust it to suit your needs. :-) HTH.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.