Question

我创建了一个宏，用于将主/主工作簿中的单元格（工作表＆＃34; Basis＆＃34;）与固定文件夹中的大约20个工作簿进行比较。如果匹配，则将单元格值复制到主工作簿。对于文件夹中的每个工作簿，此过程将继续。宏工作正常。现在，我想扩展宏以识别哪个月的数据必须在主工作簿中复制。固定文件夹中的每个工作簿都包含单元格B9，fx＆＃34; 2016年2月和＃34;中的月份。必须将B9单元格与主工作簿中的基础工作表的第一行进行比较。如果日期之间存在匹配，则启动我到目前为止创建的宏。

目前，代码已修复为循环遍历主工作簿的I列中的单元格，但应识别工作簿是否在二月，三月，四月等等。我想我需要使用InStr()和Offset()，但我不确定是多么特别，因为主工作簿中的月份都在合并的单元格中。

这是＆＃34; Basis＆＃34;主要/主要工作簿的表格：

到目前为止，这是我的代码：

Sub combineall()

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    Call lista
    Call CopyLookup

    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

    ThisWorkbook.Sheets("Basis").Activate
    ThisWorkbook.Sheets("List").Visible = False

End Sub

Sub CopyLookup()

    Dim Path As String
    Dim Fil As String
    Dim strName As String
    Dim wbk_main As Workbook, wbk1 As Workbook
    Dim ws_main As Worksheet, ws1 As Worksheet
    Dim rng_main As Range, rng1 As Range
    Dim c_main As Range, c1 As Range
    i = 2

    While ThisWorkbook.Sheets("List").Cells(i, 1) <> ""
    t = ThisWorkbook.Sheets("List").Cells(i, 1)

     'Define fixed path
    Set wbk_main = ActiveWorkbook
    Path = "I:\BS\PLAN\HQ\Saud\Opgaver\Opgaver Kompensation Fakturering\Test VBA\Test Månedsbilag\" & t

    q = 1
     'Start outer loop
    Do While q <> ""

        Set wbk1 = Workbooks.Open(Path)
        Set ws1 = wbk1.Sheets(1)

         'Split cell if containing many values
        ws1.Range("B10").Select
        Selection.TextToColumns Destination:=Range("R10"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
        Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1)), _
        TrailingMinusNumbers:=True

        'Create range objects for the two columns to be compared:
        Set rng1 = ws1.Range("R10:AL10")

        Set rng_main = ThisWorkbook.Sheets("Basis").Range("I4:I19")

         'Loop through each cell in col I:
        For Each c_main In rng_main
            If c_main.Value <> "" Then
                For Each c1 In rng1
                    If c1.Value = c_main.Value Then
                         'Copy value to main workbook:
                        c_main.Offset(0, 3).Value = wbk1.Sheets(1).Range("F13").Value
                        q = ""
                         'Move on to next cell in sheet 2:
                        Exit For '(exits the "For Each c1 In rng1" loop)

                    End If
                Next c1
            End If
        Next c_main

        rng1.Delete
        wbk1.Close False

    Loop

    i = i + 1
    Wend

End Sub


Sub lista()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim ws As Worksheet

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set ws = Worksheets.Add
    With ActiveSheet
    .Name = "List"
    End With

    fldrpath = "I:\Fixed folder"
    Set objFolder = objFSO.GetFolder(fldrpath)
    ws.Cells(1, 1).Value = "The files found in " & objFolder.Name & "are:"

    For Each objFile In objFolder.Files
        ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name
    Next

    Set objFolder = Nothing
    Set objFile = Nothing
    Set objFSO = Nothing
End Sub

比较两个工作簿中的月份（字符串）并循环

0 个答案: