[英]How to create Excel list with data that excludes certain types of combinations
[英]VBA Excel - How to recognize certain types of data
我正在嘗試建立一個宏,該宏將為我移動一個表(單元格組)到excel電子表格的另一個區域。 我目前已經構建了它(這是代碼的相關部分),但是它僅適用於一個表,因為我根據第一個表的位置對其進行了編碼。 但是,我的某些電子表格具有更多的表格,並且位置不同(所有表格都堆疊在一起,但是高度不同-所以我不容易做我為第一個表格所做的事情)。
所以我的問題是-有沒有一種方法可以對VBA進行編碼,以識別每個表的左上角(每個表的左上角的數據始終相同),然后檢測表(數據)何時都結束於那個左上角的右邊和底部,然后移動所有這些?
我對此很陌生,並為我下面的破舊“編碼”感到自豪。 任何幫助,將不勝感激。 我考慮過要使用“ If..Then”語句來檢測左上角,但不知道如何從那里去。 感謝您的任何幫助。
' 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
樣品表:
如果您有一個矩形范圍,那么要找到其左上角和右下角:
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
經過測試:
Sub MAIN()
Dim r As Range
Set r = Range("B9:J37")
Call CornerFinder(r)
End Sub
好吧,根據您的示例數據和示例代碼,嘗試一下。
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。
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.