Excel VBA：查找 - 比较两个文件 - 复制

Question

我是 VBA 新手，从 12 小时开始尝试多个代码，但没有得到修复。我真的希望你能帮助我！

我有两个 Excel 文件 例如，它看起来像这样： Input File1

它应该通过下拉列表（一月、二月、....）找到月份，并将下面的特定单元格复制到 Excel-File 2 下的一月、二月、....

此外，它应该搜索由下拉列表选择的单词（KW1，KW2，KW3，....）并复制 Excel 文件 2 中 A B C D E 下的单元格值。

喜欢： Master File2

Excel-File 2 是“Master-Excel”，使用“werte_uebergeben”按钮，您可以将值从 File1 (A1:A11) 发送到 File2 到 (A1:A11) 或 (B1:B11).. . 取决于标题

使用 File1 中的“Country”按钮，您可以将带有单元格 (E25:I25) 的 JP 行发送到 (G28:K28) 中的 File2 - 取决于单词 KW1、KW2 (G35:K35) 或 KW3 ( G42:K42)。

我真的希望通过图片可以更清楚地理解。

这是第二个作业的 sn-p，但它应该自动将其粘贴到带有“KW1”的行中。也应该放在KW1，KW2...我选择了

Sub country_Click()
Dim wsIRow As Long, wsORow As Long
Dim wsI As Worksheet, wsO As Worksheet
Dim rng As Range, aCell As Range
Dim Kalenderwoche As String

Set wsI = ThisWorkbook.Sheets("Tabelle1")
Set wsO = Workbooks.Open("C:\Users\MM\\Mappe2.xlsx").Worksheets("Tabelle1")
Kalenderwoche = ThisWorkbook.Sheets("Tabelle1").Cells(1, 1).Value

wsORow = wsO.Cells.Find(What:="*", SearchOrder:=xlByRows, _
         SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1

With wsI
    wsIRow = wsI.Cells.Find(What:="*", SearchOrder:=xlByRows, _
             SearchDirection:=xlPrevious, LookIn:=xlValues).Row

    Set rng = .Range("A2:A" & wsIRow)

    With rng
        Set aCell = .Find(What:="LOC", LookIn:=xlValues, _
                    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                    MatchCase:=True, SearchFormat:=False)

        If Not aCell Is Nothing Then

            wsO.Cells.Find(What:="LOC", SearchOrder:=xlByRows, _
         SearchDirection:=xlNext, LookIn:=xlValues).Offset(1, 1).Value = aCell.Offset(0, 1).Value
                         wsO.Cells.Find(What:="LOC", SearchOrder:=xlByRows, _
         SearchDirection:=xlNext, LookIn:=xlValues).Offset(1, 2).Value = aCell.Offset(0, 2).Value
                         wsO.Cells.Find(What:="LOC", SearchOrder:=xlByRows, _
         SearchDirection:=xlNext, LookIn:=xlValues).Offset(1, 3).Value = aCell.Offset(0, 3).Value

        End If
    End With
End With





Application.ScreenUpdating = True

结束子

提前非常非常非常感谢您！ 此致 马库斯

编辑：猜猜它现在可以工作了：D：D

Answer 1

您没有说您遇到问题的部分，但我猜它是首先搜索 KW 部分，然后继续搜索以找到其下方的国家/地区。如果是这样，也许这会有所帮助。

Option Explicit
Private Sub Country_Click()

     ' country
    Dim wsIn As Worksheet, wsOut As Worksheet
    Dim rng As Range, rngOut As Range
    Dim KW As String, Country As String

    Set wsIn = ThisWorkbook.Sheets("Tabelle1")
    Set wsOut = Workbooks.Open("C:\...\Mappe2.xlsx").Worksheets("Tabelle1")

    KW = wsIn.Range("D24").Value
    Set rng = wsIn.Range("D25:I25")
    Country = rng.Cells(1, 1)

    Set rngOut = wsOut.UsedRange.Find(KW)
    If rngOut Is Nothing Then
        MsgBox KW & "Not FOund", vbExclamation
    Else
        MsgBox KW & " Found at " & rngOut.Address, vbInformation
        Set rngOut = wsOut.UsedRange.Find(Country, rngOut)
        If rngOut Is Nothing Then
            MsgBox Country & " Not Found", vbExclamation
        Else
            MsgBox Country & " Found at " & rngOut.Address, vbInformation
            rng.Copy rngOut
            MsgBox rng.Address & " copied to " & rngOut.Address, vbInformation
        End If
    End If

End Sub

月份按钮更简单，因为您在单元格 A1 上使用下拉菜单进行了验证，您可以删除案例块。

Private Sub Mth_Click()

    ' month
    Dim wsIn As Worksheet, wsOut As Worksheet
    Dim rng As Range, rngOut As Range, mthno As Integer

    Set wsIn = ThisWorkbook.Sheets("Tabelle1")
    Set wsOut = Workbooks.Open("C:\...\Mappe2.xlsx").Worksheets("Tabelle1")

    Set rng = wsIn.Range("A1:A7")

    Select Case LCase(Left(rng.Cells(1, 1), 3))
        Case "jan", "feb", "mar", "apr", "may", "jun", _
             "jul", "aug", "sep", "oct", "now", "dec"

            mthno = Month("1 " & rng.Cells(1, 1))
            rng.Copy wsOut.Range("A1").Offset(0, mthno - 1)
            MsgBox "Copied to month " & mthno, vbInformation

        Case Else
            MsgBox "Error with Month " & rng.Cells(1, 1), vbCritical
    End Select

End Sub