Vba 动态图纸命名和复制数据_Vba_Excel

Vba 动态图纸命名和复制数据

vba excel

Vba 动态图纸命名和复制数据,vba,excel,Vba,Excel,我在这里默读了几个月，但现在已经为这段代码苦苦挣扎了一周，所以我想看看是否有人能帮上忙我有一个工作表，其中工作表1包含供用户输入数据的信息。 A列询问问题，C列是用户输入答案的位置。第4行询问将有多少配置。根据他们输入的数字，取决于右侧亮起的单元格数量，即如果1，则D4变为黄色，如果2，则D4和E4变为黄色（使用条件格式）然后，用户将标题输入突出显示的单元格（D4、E4、F4等）我想在每个配置的工作表末尾创建一个新工作表。然后根据在D4、E4等中输入的文本命名新工作表到目前为止，我掌

我在这里默读了几个月，但现在已经为这段代码苦苦挣扎了一周，所以我想看看是否有人能帮上忙

我有一个工作表，其中工作表1包含供用户输入数据的信息。 A列询问问题，C列是用户输入答案的位置。第4行询问将有多少配置。根据他们输入的数字，取决于右侧亮起的单元格数量，即如果1，则D4变为黄色，如果2，则D4和E4变为黄色（使用条件格式）然后，用户将标题输入突出显示的单元格（D4、E4、F4等）我想在每个配置的工作表末尾创建一个新工作表。然后根据在D4、E4等中输入的文本命名新工作表

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

 Option Explicit

Sub InsertSupplierSheet()

Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range

'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)

With ws
    Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column

    If Lastcol < 4 Then Exit Sub

    For i = 3 To Lastcol
        If DoesSheetExist(ActiveSheet.Cells(4 & i).Value) Then
            Set tmpSht = ActiveSheet.Cells(4 & i).Value
        Else
            Sheets.Add After:=Sheets(Sheets.Count)
            Set tmpSht = ActiveSheet
            tmpSht.Name = "NEWSHEET"


        End If

        .Rows("1:3").Copy tmpSht.Rows(1)

        For j = 1 To 4
            tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
        Next j

        .Rows(i).Copy tmpSht.Rows(4)
    Next
End With
End Sub

Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet

On Error Resume Next
Set ws = Sheets(ws)
On Error GoTo 0

If Not ws Is Nothing Then DoesSheetExist = True
End Function

应该是

    sShtName = Worksheets(1).Cells(4, i).Value2

你打错手机了。使用

（4，i）

代替

（4&i）

您调用它的方式将它连接到

，这导致您检查单元格AQ1（AQ是第43列）以获取工作表引用

编辑：我只是浏览了一下，发现了一些其他错误。您需要在“exists”函数中将工作表名称设置为

sht

，我假设您希望将

tmpSht

设置为工作表，因此需要将其封装在

sheets（）

中。试试这个：

Sub InsertSupplierSheet()

Dim ws As Worksheet 
Dim tmpSht As Worksheet
Dim Lastcol As Integer, i As Integer, j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable

'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)

With ws
Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column

If Lastcol < 4 Then Exit Sub

For i = 4 To Lastcol
    sShtName = ActiveSheet.Cells(4, i).Value2 'Set sShtName to cell value within loop
    If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
        Set tmpSht = Sheets(sShtName)
    Else
        Sheets.Add After:=Sheets(Sheets.Count)
        Set tmpSht = ActiveSheet
        tmpSht.Name = sShtName 'Change name to sShtName
    End If

    .Rows("1:3").Copy tmpSht.Rows(1)

    For j = 1 To 4
        tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
    Next j

    .Rows(i).Copy tmpSht.Rows(4)
Next
End With
End Sub

Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet

On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0

If Not ws Is Nothing Then DoesSheetExist = True
End Function

Sub InsertSupplierSheet（）
将ws设置为工作表
将tmpSht调整为工作表
Dim Lastcol为整数，i为整数，j为整数
变暗范围作为范围
Dim sShtName作为字符串“尺寸表名称变量”
“~~>将Sheet1更改为包含所有数据的工作表
设置ws=This工作簿。工作表（1）
与ws
Lastcol=ActiveSheet.Cells（4，Columns.Count）.End（xlToLeft）.Column
如果Lastcol<4，则退出Sub
对于i=4到Lastcol
sShtName=ActiveSheet.Cells（4，i）.Value2'将sShtName设置为循环中的单元格值
如果是DoesSheetExist（sShtName），则“使用sShtName调用”Exists“函数
设置tmpSht=图纸（sShtName）
其他的
Sheets.Add After:=工作表（Sheets.Count）
设置tmpSht=ActiveSheet
tmpSht.Name=sShtName'将名称更改为sShtName
如果结束
.行（“1:3”）。复制tmpSht.行（1）
对于j=1到4
tmpSht.Columns（j）.ColumnWidth=.Columns（j）.ColumnWidth
下一个j
.Rows（i）.复制tmpSht.Rows（4）
下一个
以
端接头
函数DoesSheetExist（Sht为字符串）为布尔值
将ws设置为工作表
出错时继续下一步
设置ws=图纸（Sht）
错误转到0
如果不是ws为Nothing，则DoesSheetExist=True
端函数

您可以使用较短的方式（见下文）而不是添加新工作表，然后将activesheet设置为tmpsht。如果你不使用ws，为什么要设置它

Sub InsertSupplierSheet()

    Dim ws As Worksheet 
    Dim tmpSht As Worksheet
    Dim Lastcol As Integer, i As Integer, j As Integer
    Dim DESCRANGE As Range

    Set ws = ThisWorkbook.Worksheets(1)

    With ws
        Lastcol = .Cells(4, .Columns.Count).End(xlToLeft).Column

        If (Lastcol < 4) Then
            Exit Sub
        End If

        For i = 4 To Lastcol
            If (DoesSheetExist(.Cells(4, i).Value2) = True) Then
                Set tmpSht = Sheets(.Cells(4, i).Value)
            Else
                Set tmpSht = Sheets.Add After:=Sheets(Sheets.Count)
                tmpSht.Name = "NEWSHEET"
            End If

            .Rows("1:3").Copy tmpSht.Rows(1)

            For j = 1 To 4
                tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
            Next j

            .Rows(i).Copy tmpSht.Rows(4)
        Next i
    End With
End Sub


Function DoesSheetExist(Sht As String) As Boolean

    Dim ws As Worksheet

    On Error Resume Next
    Set ws = Sheets(Sht)
    On Error GoTo 0

    If Not ws Is Nothing Then
        DoesSheetExist = True
    Else
        DoesSheetExist = False
    End If

End Function

Sub InsertSupplierSheet（）
将ws设置为工作表
将tmpSht调整为工作表
Dim Lastcol为整数，i为整数，j为整数
变暗范围作为范围
设置ws=This工作簿。工作表（1）
与ws
Lastcol=.Cells（4，.Columns.Count）.End（xlToLeft）.Column
如果（Lastcol<4），则
出口接头
如果结束
对于i=4到Lastcol
如果（DoesSheetExist（.Cells（4，i）.Value2）=True），则
设置tmpSht=图纸（.Cells（4，i）.Value）
其他的
设置tmpSht=工作表。之后添加：=工作表（Sheets.Count）
tmpSht.Name=“新闻纸”
如果结束
.行（“1:3”）。复制tmpSht.行（1）
对于j=1到4
tmpSht.Columns（j）.ColumnWidth=.Columns（j）.ColumnWidth
下一个j
.Rows（i）.复制tmpSht.Rows（4）
接下来我
以
端接头
函数DoesSheetExist（Sht为字符串）为布尔值
将ws设置为工作表
出错时继续下一步
设置ws=图纸（Sht）
错误转到0
如果不是的话，那么ws什么都不是
DoesSheetExist=真
其他的
DoesSheetExist=False
如果结束
端函数

这是我最后的代码。有一些调整，首先我在第6行中添加了一个公式，将第4行的名称缩短为10个字符的名称，因为我发现选项卡名称太长（因此命名代码引用第6行）。我还添加了一些自定义文本以添加到每个工作表中，并设置了一些格式

Option Explicit


Sub InsertSupplierSheet()

Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer
Dim i As Integer
Dim j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable

'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)

With ws

Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column ' work         with the template sheet

If Lastcol = 3 Then Exit Sub 'repeat these steps from the first config to the last

For i = 4 To Lastcol

sShtName = Worksheets(1).Cells(6, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
   Set tmpSht = Sheets(sShtName)
Else
    Sheets.Add After:=Sheets(Sheets.Count)
    Set tmpSht = ActiveSheet
    tmpSht.Name = sShtName 'Change name to sShtName tmpSht.Name = sShtName
End If

.Rows("1:3").Copy tmpSht.Rows(1) ' Format the cell width in the new sheet
.Rows(13).Copy tmpSht.Rows(4)
 tmpSht.Range("A1").Value = Worksheets(1).Cells(4, i).Value2
 Range("A1").ColumnWidth = 30
 Range("B1").ColumnWidth = 0
 Range("C1").ColumnWidth = 30
 Range("D1:K1").ColumnWidth = 10
 Range("D4:J4").Font.Color = vbWhite ' format the colour of the text in the new sheet
 Range("C1") = " "    ' Negate info in cell C1

 With Range("A1:M5") ' add borders

'Clear existing
.Borders.LineStyle = xlNone

'Apply new borders
.BorderAround xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous

End With
 With Range("A1:C4") ' set colours for the new sheet
  .Font.Color = vbBlack
  .Interior.Color = vbWhite

 End With
 Range("D4:J4").Font.Color = vbWhite ' set colour of the numbers to white to show on black background
 Range("A5") = "Unit cost in " & Worksheets(1).Cells(17, 3).Value2
 Range("A6") = "CUSTOM TEXT ONE."
 Range("A7") = "NOTE if quantity " & Range("D4").Value2 + 5 & " is ordered then total cost will be your unit cost for " & Range("D4").Value2 & " multiplied by " & Range("D4").Value2 + 5 & " .This applies up to the quantity of " & Range("E4").Value2 - 1
 Range("A8") = "CUSTOM TEXT 2"


Next i
End With
End Sub

Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet

On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0

If Not ws Is Nothing Then DoesSheetExist = True
End Function

如果我的答案有帮助，请将其标记为已接受的答案。如果没有，请让我知道我可以如何提供更多帮助。嗨，JMcD这是一个很大的帮助。我现在正在创建新的工作表，并复制信息。现在我需要解决如何使用单元格D4中的信息重命名工作表，以及如何使用下一个单元格E4中的信息重命名工作表等。如果设置为他为一个变量命名，因为您将在多个地方使用它。我将更新上面的代码示例以说明我的意思。我刚刚更新了它，并添加了注释以说明如何执行该操作。如果您还有其他问题，请告诉我。Hi@JMcD这更有希望，我正在测试包含5个描述的工作表（此工作表允许的最大值）前2个工作表名为desc 2，desc 3为单元格D4，E4，然后添加工作表“sheet6”并失败。运行时错误1004方法“对象名称”_工作表失败。感谢您的暂停，但我无法使其正常工作，我有一个syntex错误。设置tmpSht=Sheets。之后添加：=Sheets（Sheets.Count）好的，那么我想这是行不通的。您可以对该部分使用代码，这样“sheets.add after:=sheets（sheets.count）”然后“set tmpSht=ActiveSheet”“tmpSht.Name=（.Cells（4，I）.Value）”

Sub InsertSupplierSheet()

    Dim ws As Worksheet 
    Dim tmpSht As Worksheet
    Dim Lastcol As Integer, i As Integer, j As Integer
    Dim DESCRANGE As Range

    Set ws = ThisWorkbook.Worksheets(1)

    With ws
        Lastcol = .Cells(4, .Columns.Count).End(xlToLeft).Column

        If (Lastcol < 4) Then
            Exit Sub
        End If

        For i = 4 To Lastcol
            If (DoesSheetExist(.Cells(4, i).Value2) = True) Then
                Set tmpSht = Sheets(.Cells(4, i).Value)
            Else
                Set tmpSht = Sheets.Add After:=Sheets(Sheets.Count)
                tmpSht.Name = "NEWSHEET"
            End If

            .Rows("1:3").Copy tmpSht.Rows(1)

            For j = 1 To 4
                tmpSht.Columns(j).ColumnWidth = .Columns(j).ColumnWidth
            Next j

            .Rows(i).Copy tmpSht.Rows(4)
        Next i
    End With
End Sub


Function DoesSheetExist(Sht As String) As Boolean

    Dim ws As Worksheet

    On Error Resume Next
    Set ws = Sheets(Sht)
    On Error GoTo 0

    If Not ws Is Nothing Then
        DoesSheetExist = True
    Else
        DoesSheetExist = False
    End If

End Function

Option Explicit


Sub InsertSupplierSheet()

Dim ws As Worksheet
Dim tmpSht As Worksheet
Dim Lastcol As Integer
Dim i As Integer
Dim j As Integer
Dim DESCRANGE As Range
Dim sShtName As String 'Dimension sheet name variable

'~~> Change Sheet1 to the sheet which has all the data
Set ws = ThisWorkbook.Worksheets(1)

With ws

Lastcol = ActiveSheet.Cells(4, Columns.Count).End(xlToLeft).Column ' work         with the template sheet

If Lastcol = 3 Then Exit Sub 'repeat these steps from the first config to the last

For i = 4 To Lastcol

sShtName = Worksheets(1).Cells(6, i).Value2 'Set sShtName to cell value within loop
If DoesSheetExist(sShtName) Then 'Use sShtName to call "Exists" function
   Set tmpSht = Sheets(sShtName)
Else
    Sheets.Add After:=Sheets(Sheets.Count)
    Set tmpSht = ActiveSheet
    tmpSht.Name = sShtName 'Change name to sShtName tmpSht.Name = sShtName
End If

.Rows("1:3").Copy tmpSht.Rows(1) ' Format the cell width in the new sheet
.Rows(13).Copy tmpSht.Rows(4)
 tmpSht.Range("A1").Value = Worksheets(1).Cells(4, i).Value2
 Range("A1").ColumnWidth = 30
 Range("B1").ColumnWidth = 0
 Range("C1").ColumnWidth = 30
 Range("D1:K1").ColumnWidth = 10
 Range("D4:J4").Font.Color = vbWhite ' format the colour of the text in the new sheet
 Range("C1") = " "    ' Negate info in cell C1

 With Range("A1:M5") ' add borders

'Clear existing
.Borders.LineStyle = xlNone

'Apply new borders
.BorderAround xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous

End With
 With Range("A1:C4") ' set colours for the new sheet
  .Font.Color = vbBlack
  .Interior.Color = vbWhite

 End With
 Range("D4:J4").Font.Color = vbWhite ' set colour of the numbers to white to show on black background
 Range("A5") = "Unit cost in " & Worksheets(1).Cells(17, 3).Value2
 Range("A6") = "CUSTOM TEXT ONE."
 Range("A7") = "NOTE if quantity " & Range("D4").Value2 + 5 & " is ordered then total cost will be your unit cost for " & Range("D4").Value2 & " multiplied by " & Range("D4").Value2 + 5 & " .This applies up to the quantity of " & Range("E4").Value2 - 1
 Range("A8") = "CUSTOM TEXT 2"


Next i
End With
End Sub

Function DoesSheetExist(Sht As String) As Boolean
Dim ws As Worksheet

On Error Resume Next
Set ws = Sheets(Sht)
On Error GoTo 0

If Not ws Is Nothing Then DoesSheetExist = True
End Function