时间戳

首页 > 解决方案 > VBA/宏问题创建正确高度/宽度的表格并在没有电子表格最后一行的情况下创建该表格

excel - VBA/宏问题创建正确高度/宽度的表格并在没有电子表格最后一行的情况下创建该表格

问题描述

我已经写了（在 StackOverflow 的帮助下，谢谢！）一个宏

我在“查找范围的右下角，向上移动一行并选择回到“家”并命名表名”时遇到问题。

高层次的想法是我不希望每个文件底部的摘要行。

我不确定我是否为此部分选择了“最佳”解决方案（我实际上更喜欢：

此外，创建的表“始终”为 8 行高 x 19 列（S 列）宽。

我正在就两个相关项目寻求帮助：

'Find the bottom right of the range, move up one row and select back to "home" and make a table name
Range("A1").Select
Range(Selection, Selection.SpecialCells(xlLastCell)). _
Resize(Range(Selection, Selection.SpecialCells(xlLastCell)).Columns.Count, _
Range(Selection, Selection.SpecialCells(xlLastCell)).Rows.Count - 1).Select
ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "xARPatient"

Sub aaaa()
Dim wb_source As Workbook
Dim wb_target As Workbook

Application.DisplayAlerts = False

Set wb_target = Workbooks.Open("c:\Test\MEBIllingOffice.xlsm")
'assuming the sheet name is "xAccountARAgingPatient.xlsx" note - sheet names must be unique within target


'Import File #1''''''''''''''''''''''''''''''''''''''''''
'import file as a worksheet from other worbooks in the same directory
    Set wb_source = Workbooks.Open("C:\Test\xAccountARAgingPatient.xlsx")
      For Each ws In Worksheets
        For Each LO In ws.ListObjects
          LO.Unlist
        Next
      Next
wb_source.Sheets("xAccountARAgingPatient.xlsx").Copy after:=wb_target.Sheets(wb_target.Sheets.Count)
'remove extraneous formatting
Cells.Select
Cells.EntireColumn.AutoFit
Selection.ClearFormats
ActiveWindow.FreezePanes = False
'Find the bottom right of the range, move up one row and select back to "home" and make a table name
Range("A1").Select
Range(Selection, Selection.SpecialCells(xlLastCell)). _
Resize(Range(Selection, Selection.SpecialCells(xlLastCell)).Columns.Count, _
Range(Selection, Selection.SpecialCells(xlLastCell)).Rows.Count - 1).Select
ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "xARPatient"
wb_source.Close

'Import File #2''''''''''''''''''''''''''''''''''''''''''
'import file as a worksheet from other worbooks in the same directory
    Set wb_source = Workbooks.Open("C:\Test\xAccountARAgingPayer.xlsx")
      For Each ws In Worksheets
        For Each LO In ws.ListObjects
          LO.Unlist
        Next
      Next
wb_source.Sheets("xAccountARAgingPayer.xlsx").Copy after:=wb_target.Sheets(wb_target.Sheets.Count)
'remove extraneous formatting
Cells.Select
Cells.EntireColumn.AutoFit
Selection.ClearFormats
ActiveWindow.FreezePanes = False
'Find the bottom right of the range, move up one row and select back to "home" and make a table name
Range("A1").Select
Range(Selection, Selection.SpecialCells(xlLastCell)). _
Resize(Range(Selection, Selection.SpecialCells(xlLastCell)).Columns.Count, _
Range(Selection, Selection.SpecialCells(xlLastCell)).Rows.Count - 1).Select
ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "xARPayer"
wb_source.Close
''''''''''''''''''''''''''''''''''''''''''

'wb_target.Save
'wb_target.Close

Application.DisplayAlerts = True
End Sub

标签： excelvbaoffice365ms-office

解决方案

你可以尝试这样的事情：

Dim rng As range, ws as worksheet

set ws = Activesheet
set rng = ws.Range("a1").currentregion  'select whole table
set rng = rng.resize(rng.rows.count - 1, rng.columns.count) 'make one row shorter...
ws.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "xARPayer"

推荐阅读