Vba 具有两个单元格值条件的Excel工作表.name_Vba_Excel

Vba 具有两个单元格值条件的Excel工作表.name

vba excel

Vba 具有两个单元格值条件的Excel工作表.name,vba,excel,Vba,Excel,我今天的问题是，在命名新工作表时，尝试使其具有两个不同的cell.values 当前代码从一个选项卡获取数据，并根据单元格范围K7中的内容创建不同的工作表。因此，每个选项卡都填充了基于K7列的数据。目前，我已将新工作表名称设置为 wsnew.name = "NIIN " + cell.value 它完成了它的工作，并带回标签为“NIIN xxxxxxxx”的标签我还有一个标题为“样本”的专栏，范围从A7开始如果该列具有相同的K7值，则该列的值都相同有没有办法让VBA从A7和K7中找到单元

我今天的问题是，在命名新工作表时，尝试使其具有两个不同的cell.values

当前代码从一个选项卡获取数据，并根据单元格范围K7中的内容创建不同的工作表。因此，每个选项卡都填充了基于K7列的数据。目前，我已将新工作表名称设置为

wsnew.name = "NIIN " + cell.value

它完成了它的工作，并带回标签为“NIIN xxxxxxxx”的标签

我还有一个标题为“样本”的专栏，范围从A7开始

如果该列具有相同的K7值，则该列的值都相同

有没有办法让VBA从A7和K7中找到单元格值并将其添加到工作表名称中

理想情况下，我希望它是这样的

wsnew.name = "Sample " + cell.value (a7 range) + " NIIN " + cell.value (k7 range)

添加提供的代码会给我工作表名称，如“Sample xxxxxx NIIN”

xxxxx实际上应该位于NIIN的前面，这样它就会显示“Sample…..NIIN xxxxxx”

这是我添加的代码，它将格式转换为“Sample NIIN xxxxxx”

这工作得很好，但我仍然没有得到样本后的值

我尝试了

cell.offset（O，-10）.value

，但这给了我一个错误

下面的代码是工作表命名之前的代码

Set ws2 = Worksheets.Add

    With ws2
        'first we copy the Unique data from the filter field to ws2
        My_Table.ListColumns(FieldNum).Range.AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True

        'loop through the unique list in ws2 and filter/copy to a new sheet
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)

            'Filter the range
            My_Table.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
                                                                  Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

            CCount = 0
            On Error Resume Next
            CCount = My_Table.ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
            On Error GoTo 0

            If CCount = 0 Then
                MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                     & vbNewLine & "It is not possible to copy the visible data to a new worksheet." _
                     & vbNewLine & "Tip: Sort your data before you use this macro.", _
                       vbOKOnly, "Split in worksheets"

我希望这些图片有助于回答这个问题

正如您在单击宏时从图片中看到的，它根据K7（NIIN字段）中的标准创建了许多图纸

正如您还可以看到的，EY Sample下的值是我希望在“Sample…”之后的输出中得到的值

因此它的读数（例如）“样本5 NIIN 1212”

这是全部代码。我相信有一个更好的方式写出来。我运用了我的基本知识和经验。很多人都为这造成的头痛道歉

Sub Copy_To_Worksheets()
Dim CalcMode As Long
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim FieldNum As Long
Dim My_Table As ListObject
Dim ErrNum As Long
Dim ActiveCellInTable As Boolean
Dim CCount As Long

'Select a cell in the column that you want to filter in the List or Table

Application.GoTo Sheets("SplitInWorksheets").Range("K7")

If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
MsgBox "This macro is not working when the workbook or worksheet is protected", _
           vbOKOnly, "Copy to new worksheet"
    Exit Sub
End If

Set rng = ActiveCell

'Test if rng is in a a list or Table
On Error Resume Next
ActiveCellInTable = (rng.ListObject.Name <> "")
On Error GoTo 0

'If the cell is in a List or Table run the code
If ActiveCellInTable = True Then

    Set My_Table = rng.ListObject
    FieldNum = rng.Column - My_Table.Range.Cells(1).Column + 1

    'Show all data in the Table/List
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    ' Add a worksheet to copy the a unique list and add the CriteriaRange
    Set ws2 = Worksheets.Add

    With ws2
        'first we copy the Unique data from the filter field to ws2
        My_Table.ListColumns(FieldNum).Range.AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True




  'loop through the unique list in ws2 and filter/copy to a new sheet
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)

            'Filter the range
            My_Table.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
                                                                  Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

            CCount = 0
            On Error Resume Next
            CCount = My_Table.ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
            On Error GoTo 0

            If CCount = 0 Then
                MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                     & vbNewLine & "It is not possible to copy the visible data to a new worksheet." _
                     & vbNewLine & "Tip: Sort your data before you use this macro.", _
                       vbOKOnly, "Split in worksheets"
            Else
                Set WSNew = Worksheets.Add(after:=Sheets(Sheets.Count))
                On Error Resume Next
                WSNew.Name = "Sample " & cell.Offset(0, 10).Value & " NIIN " & cell.Value

                If Err.Number > 0 Then
                    ErrNum = ErrNum + 1
                    WSNew.Name = "Error_" & Format(ErrNum, "0000")
                    Err.Clear
                End If
                On Error GoTo 0

                'Copy the visible data and use PasteSpecial to paste to the new worksheet
                My_Table.Range.SpecialCells(xlCellTypeVisible).Copy
                With WSNew.Range("A1")
                    .PasteSpecial xlPasteColumnWidths
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                    .Select
                End With
            End If

            'Show all data in the Table/List
            My_Table.Range.AutoFilter Field:=FieldNum

        Next cell

       'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        On Error GoTo 0



    End With

    If ErrNum > 0 Then MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" & vbNewLine & _
       "There are characters in the Unique name that are not allowed in a sheet name or the sheet exist."

    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With
Else
    MsgBox "Select a cell in the column of the List or Table that you want to  filter"
End If

End Sub

Sub-Copy_To_工作表（）
暗淡的CalcMode与长
将ws2设置为工作表
将ws3设置为工作表
新建为工作表
变暗rng As范围
暗淡单元格作为范围
暗淡的光线和长的一样
Dim FieldNum尽可能长
将我的_表设置为ListObject
Dim ErrNum尽可能长
Dim ActiveCellInTable作为布尔值
长帐
'在列表或表格中选择要筛选的列中的单元格
申请表格（“拆分工作表”）。范围（“K7”）
如果ActiveWorkbook.ProtectStructure=True或ActiveSheet.ProtectContents=True，则
MsgBox“工作簿或工作表受保护时，此宏不起作用”_
vbOKOnly，“复制到新工作表”
出口接头
如果结束
设置rng=ActiveCell
'测试rng是否在列表或表格中
出错时继续下一步
ActiveCellInTable=（rng.ListObject.Name“”）
错误转到0
'如果单元格位于列表或表格中，请运行代码
如果ActiveCellInTable=True，则
设置My_Table=rng.ListObject
FieldNum=rng.Column-My_Table.Range.Cells（1）.Column+1
'显示表/列表中的所有数据
出错时继续下一步
ActiveSheet.ShowAllData
错误转到0
应用
CalcMode=.Calculation
.Calculation=xlCalculationManual
.ScreenUpdate=False
以
'添加工作表以复制唯一列表并添加标准范围
设置ws2=工作表。添加
与ws2
'首先，我们将唯一数据从筛选器字段复制到ws2
My_Table.ListColumns（FieldNum）.Range.AdvancedFilter_
操作：=xlFilterCopy_
CopyToRange:=.Range（“A1”），唯一：=真
'循环浏览ws2中的唯一列表并筛选/复制到新工作表
Lrow=.Cells（Rows.Count，“A”）.End（xlUp）.Row
对于.Range中的每个单元格（“A2:A”和Lrow）
'过滤范围
My_Table.Range.AutoFilter字段：=FieldNum，Criteria1:=“=”&_
替换（替换（替换（cell.Value、“~”、“~~”、“*”、“~*”、“？”、“~？”）
帐户=0
出错时继续下一步
CCount=My_Table.ListColumns（1）.Range.SpecialCells（xlCellTypeVisible）.Areas（1）.Cells.Count
错误转到0
如果CCount=0，则
MsgBox“值有8192个以上的区域：”&cell.value_
&vbNewLine&“无法将可见数据复制到新工作表。”_
&vbNewLine&“提示：在使用此宏之前对数据进行排序。”_
VBookOnly，“在工作表中拆分”
其他的
设置WSNew=Worksheets.Add（之后：=Sheets（Sheets.Count））
出错时继续下一步
WSNew.Name=“Sample”和cell.Offset（0,10）.Value&“NIIN”和cell.Value
如果错误编号>0，则
ErrNum=ErrNum+1
WSNew.Name=“Error”&格式（ErrNum，“0000”）
呃，明白了
如果结束
错误转到0
'复制可见数据并使用PasteSpecial粘贴到新工作表
My_Table.Range.SpecialCells（xlCellTypeVisible）。复制
使用WSNew.Range（“A1”）
.Paste特殊XLPaste柱宽
.Paste特殊XLPaste值
.Paste特殊XLPaste格式
Application.CutCopyMode=False
.选择
以
如果结束
'显示表/列表中的所有数据
My_Table.Range.AutoFilter字段：=FieldNum
下一个细胞
'删除ws2工作表
出错时继续下一步
Application.DisplayAlerts=False
.删除
Application.DisplayAlerts=True
错误转到0
以
如果ErrNum>0，则MsgBox“手动重命名每个以“Error_uu”开头的工作表名”&vbNewLine&_
“工作表名称或工作表存在唯一名称中不允许的字符。”
应用
.ScreenUpdate=True
.Calculation=CalcMode
以
其他的
MsgBox“选择
Sub Copy_To_Worksheets()
Dim CalcMode As Long
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim FieldNum As Long
Dim My_Table As ListObject
Dim ErrNum As Long
Dim ActiveCellInTable As Boolean
Dim CCount As Long

'Select a cell in the column that you want to filter in the List or Table

Application.GoTo Sheets("SplitInWorksheets").Range("K7")

If ActiveWorkbook.ProtectStructure = True Or ActiveSheet.ProtectContents = True Then
MsgBox "This macro is not working when the workbook or worksheet is protected", _
           vbOKOnly, "Copy to new worksheet"
    Exit Sub
End If

Set rng = ActiveCell

'Test if rng is in a a list or Table
On Error Resume Next
ActiveCellInTable = (rng.ListObject.Name <> "")
On Error GoTo 0

'If the cell is in a List or Table run the code
If ActiveCellInTable = True Then

    Set My_Table = rng.ListObject
    FieldNum = rng.Column - My_Table.Range.Cells(1).Column + 1

    'Show all data in the Table/List
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    ' Add a worksheet to copy the a unique list and add the CriteriaRange
    Set ws2 = Worksheets.Add

    With ws2
        'first we copy the Unique data from the filter field to ws2
        My_Table.ListColumns(FieldNum).Range.AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True




  'loop through the unique list in ws2 and filter/copy to a new sheet
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)

            'Filter the range
            My_Table.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
                                                                  Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

            CCount = 0
            On Error Resume Next
            CCount = My_Table.ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
            On Error GoTo 0

            If CCount = 0 Then
                MsgBox "There are more than 8192 areas for the value : " & cell.Value _
                     & vbNewLine & "It is not possible to copy the visible data to a new worksheet." _
                     & vbNewLine & "Tip: Sort your data before you use this macro.", _
                       vbOKOnly, "Split in worksheets"
            Else
                Set WSNew = Worksheets.Add(after:=Sheets(Sheets.Count))
                On Error Resume Next
                WSNew.Name = "Sample " & cell.Offset(0, 10).Value & " NIIN " & cell.Value

                If Err.Number > 0 Then
                    ErrNum = ErrNum + 1
                    WSNew.Name = "Error_" & Format(ErrNum, "0000")
                    Err.Clear
                End If
                On Error GoTo 0

                'Copy the visible data and use PasteSpecial to paste to the new worksheet
                My_Table.Range.SpecialCells(xlCellTypeVisible).Copy
                With WSNew.Range("A1")
                    .PasteSpecial xlPasteColumnWidths
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                    .Select
                End With
            End If

            'Show all data in the Table/List
            My_Table.Range.AutoFilter Field:=FieldNum

        Next cell

       'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        On Error GoTo 0



    End With

    If ErrNum > 0 Then MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" & vbNewLine & _
       "There are characters in the Unique name that are not allowed in a sheet name or the sheet exist."

    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With
Else
    MsgBox "Select a cell in the column of the List or Table that you want to  filter"
End If

End Sub

WSNew.Name = "Sample " & cell.Value & " NIIN " & cell.Offset(0,10).Value
'SheetName =  Sample   +     A7     +   NIIN   +          K7