时间戳

首页 > 解决方案 > 根据变量定义的路径从多个关闭的工作簿中导入数据

excel - 根据变量定义的路径从多个关闭的工作簿中导入数据

问题描述

我在试图找到解决问题的方法时碰壁了。这是我正在尝试做的事情的摘要：

情况：我每周收到 4 个相同的工作表，我需要在我的摘要工作表上合并数据：

年 星期 1号镇 2号镇 3号镇 4号镇
2021 第 1 周
2021 第 2 周

工作表：我每周都会收到相同的工作表，其中包含我需要拉出的单元格的路径，如下所示：

A:\Network\2021\Week 1[Town 1.xlsx]Sheet1'!$D$4'

A:\Network\2021\Week 1[Town 2.xlsx]Sheet1'!$D$4'

A:\Network\2021\Week 1[Town 3.xlsx]Sheet1'!$D$4'

A:\Network\2021\Week 1[Town 4.xlsx]Sheet1'!$D$4'

想法/解决方案：

用户想要填充第 1 周的数据：

  1. 使用 InputBox 提示用户输入年和周，这将成为文件路径中的变量以提取数据

  2. 输入将创建文件路径： A:\Network\ Year Input \ Week Input \ [ Header .xlsx]Sheet1'!$D$4'

  3. 然后使用该输入从每个工作簿中提取数据

我现在在哪里：

从我的研究来看，我似乎必须使用 vba 来实现这一点，但我不是专家，你会碰巧知道一个更简单的方法，或者让我知道我的代码是否在正确的轨道上？

Sub AddANewWeek ()
    ' ------------- Town Summary Worksheet -------------
    
    Application.ScreenUpdating = False
    
    Worksheets("Town Summary").Activate
    
    Dim Town_Summary As Worksheet
    Set Town_Summary = Worksheets("Town Summary")
    
    '------------- User inputs the name of the Year-Week to extract the data -------------
    
    On Error GoTo ErrorMessage
    
    Dim myYear As Variant
    myYear = InputBox("Please enter the Year to extract data:")

    On Error GoTo ErrorMessage
    
    Dim myWeek As Variant
    myWeek = InputBox("Please enter the Week to extract data:")

标签： excelvbaxlsxxlsm

解决方案

在此处输入图像描述

在尝试之前在代码的 CONFIG 区域进行必要的更改。

Sub add_new_week()

Dim path As String, root_path As String
Dim town_data As String, slash As String
Dim year As Long, next_col As Long, N As Long, week_number As Long
Dim town1_col As Integer, town1_row As Integer, next_row As Integer
Dim input_range As Range
Dim source_wb As Workbook, main_wb As Workbook

Set main_wb = ActiveWorkbook

'CONFIG
'---------------------------------
root_path = "A:\Network\"
town_data = "D4" 'set the range for the source data
town1_col = 4    'set the COLUMN number for Town 1 in Town Summary sheet
town1_row = 5    'set the ROW number for Town 1 in Town Summary sheet
'---------------------------------

Set input_range = _
Application.InputBox("Where would you like to start pasting the data?", Type:=8)

week_number = InputBox("Please enter the WEEK NUMBER to extract data")

next_row = input_range.Row
next_col = input_range.Column

'Windows and Mac compatibility
slash = Application.PathSeparator

'if is december or january input the year
If format$(Date, "mmmm") = "December" Or format$(Date, "mmmm") = "January" Then
    year = InputBox("Please enter the YEAR to extract data")
    Else: year = format$(Date, "yyyy")
End If

For N = 1 To 4
   
    On Error GoTo ErrMsg
    path = _
    root_path & year & slash & "Week " & week_number & slash & _
    main_wb.Sheets("Town Summary").Cells(town1_row, town1_col) & ".xlsx"
    
    If file_exists(path) = True Then
    
        Set source_wb = Application.Workbooks.Open(path)
        
        source_wb.Sheets("Sheet1").Range(town_data).Copy
        main_wb.Sheets("Town Summary").Cells(next_row, next_col).PasteSpecial
        
        source_wb.Close

    End If

    next_col = next_col + 1
    town1_col = town1_col + 1

Next

format_table

main_wb.Sheets("Town Summary").Range("A1").Select

Exit Sub

ErrMsg:
MsgBox ("Please enter a valid number."), , "Week number not found"

End Sub

Function file_exists(path As String) As Boolean

Dim test As String

    test = ""

    On Error Resume Next
    test = Dir(path)
    On Error GoTo 0
    If test = "" Then
        file_exists = False
    Else
        file_exists = True
    End If
    
End Function

Sub format_table()

    Cells.Select
    With Selection
        .HorizontalAlignment = xlLeft
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.InsertIndent 1
    With Selection.Font
        .Name = "Calibri"
        .Size = 14
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Selection.RowHeight = 22
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 1
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub

推荐阅读