VBA Excel – 如何识别某些types的数据

我试图build立一个macros，将移动一个表格（一组单元格）我的Excel电子表格的另一个领域。 我目前已经build立了这个（这是代码的相关部分），但它只适用于一个表，因为我根据第一个表的位置进行编码。 然而，我的一些电子表格有更多的表格，不同的位置（所有的表格堆叠在一起，但高度不一样 – 所以我不能轻易地做我已经做的第一张表）。

所以我的问题是 – 是否有一种方法来编写VBA来识别每个表的左上angular（左上angular的数据总是与每个表相同），然后检测表（数据）何时结束那个左上angular的右边和底部，然后移动这一切？

我对此非常陌生，诚实地为我的寒酸“编码”感到骄傲。 任何帮助，将不胜感激。 我想过使用“If..Then”语句来检测左上angular，但不知道如何从那里出发。 感谢您的任何帮助。

' 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 

样品表：

Answer 1

好的根据您的示例数据和示例代码，试试这个。

 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 

这将数据合并到一个表中。
我用复制而不是剪切是安全的。 你可以改变它适合你。
因为我正在使用复制，所以还使用另一个表单作为输出。

例如，您在Sheet1中具有以下内容：

它将被合并到Sheet2中，如下所示：

这是你想要的吗？ 如果没有，你可以继续学习代码。
然后，一旦你做了，调整它，以满足您的需求。 🙂 HTH。

Answer 2

如果你有一个矩形范围，然后find它的左上angular和右下angular：

 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 

经testing：

 Sub MAIN() Dim r As Range Set r = Range("B9:J37") Call CornerFinder(r) End Sub