Question

我希望你能提供帮助。我在下面有一些代码可以正常工作。它的作用是打开一个对话框，允许用户选择一个excel文件。

代码通过列标题查找文本“CountryCode”然后剪切此列将其放入列F，然后根据国家/地区将列F分成新的工作表。

我面临的问题是，有时我要剪切的列包含文字“ClientField10”或“ClientField1”

所以我希望宏做的是在列标题中搜索“CountryCode”如果找到这个，请执行其余的代码。

如果 NOT 找到“CleintField10”，则会找到执行，如果“CountyCode”或“CleintField10 “被发现搜索”CleintField1“然后执行其余代码

我的代码如下所示，我们非常感谢任何帮助。

Sub Open_Workbook_Dialog()

Dim my_FileName As Variant
Dim my_Workbook As Workbook

  MsgBox "Pick your TOV file" '<--| txt box for prompt to pick a file

  my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection

  If my_FileName <> False Then
    Set my_Workbook = Workbooks.Open(Filename:=my_FileName)

    Call Sample(my_Workbook) '<--|Calls the Filter Code and executes

    Call Filter(my_Workbook) '<--|Calls the Filter Code and executes

  End If
End Sub

Public Sub Sample(my_Workbook As Workbook)
  Dim ws As Worksheet
  Dim aCell As Range, Rng As Range
  Dim col As Long, lRow As Long
  Dim colName As String

  '~~> Change this to the relevant sheet
  Set ws = my_Workbook.Sheets(1)
  With ws
    Set aCell = .Range("A1:BB50").Find(What:="CountryCode", LookIn:=xlValues, LookAt:=xlWhole, _
                MatchCase:=False, SearchFormat:=False)
    '~~> If Found
    If Not aCell Is Nothing Then
      '~~> Cut the entire column

      aCell.EntireColumn.Cut

      '~~> Insert the column here

      Columns("F:F").Insert Shift:=xlToRight
    Else
      MsgBox "Country Not Found"
    End If
  End With
End Sub

Public Sub Filter(my_Workbook As Workbook)
  Dim rCountry As Range, helpCol As Range

  With my_Workbook.Sheets(1) '<--| refer to data worksheet
    With .UsedRange
      Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in
    End With

    With .Range("A1:Q" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Q" from row 1 to last non empty row of column "A"
      .Columns(6).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 6th column of the referenced range and store its unique values in "helper" column
      Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row)
      For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row)
        .AutoFilter 6, rCountry.Value2 '<--| filter data on country field (6th column) with current unique country name
        If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered...
          Worksheets.Add Worksheets(Worksheets.Count) '<--... add new sheet
          ActiveSheet.Name = rCountry.Value2  '<--... rename it
          .SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header
        End If
      Next
    End With
    .AutoFilterMode = False '<--| remove autofilter and show all rows back
  End With
  helpCol.Offset(-1).End(xlDown).Clear '<--| clear helper column (header included)
End Sub

Answer 1

因为我之前没有测试过我的代码，所以我犯了一个使用＆＃34;如果＆＃34;而不是＆＃34; ElseIf＆＃34;声明。我测试了下面的代码，现在它可以工作。

Sub test()
Dim acell As Range
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets(1)    'define ws
Set acell = ws.Range("A1:BB50").Find(What:="CountryCode", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False)    'define acell as location of "countrycode"

If Not acell Is Nothing Then     'if address is found do the cut & insert of that column
  acell.EntireColumn.Cut
  Columns("F:F").Insert Shift:=xlToRight
ElseIf acell Is Nothing Then         'if address is not found redefine acell to look for "clientfield10"
    Set acell = ws.Range("A1:BB50").Find(What:="ClientField10", LookIn:=xlValues, LookAt:=xlWhole, _
    MatchCase:=False, SearchFormat:=False)

    If Not acell Is Nothing Then    'if address is found do the cut & insert
        acell.EntireColumn.Cut
        Columns("F:F").Insert Shift:=xlToRight
    ElseIf acell Is Nothing Then    'If not found redefine acell again to look for "ClientField1"
           Set acell = ws.Range("A1:BB50").Find(What:="ClientField1", LookIn:=xlValues, LookAt:=xlWhole, _
           MatchCase:=False, SearchFormat:=False)

            If Not acell Is Nothing Then    'If found do cut and insert
            acell.EntireColumn.Cut
            Columns("F:F").Insert Shift:=xlToRight
            Else: MsgBox "Country Not Found"    'If none can be found display msgbox
            End If
    End If
End If    'close all the If loops
End Sub

我将删除旧的答案，以便让这个帖子更容易理解

VBA修改代码。列标题针对不同工作簿的更改

1 个答案: