动态工作表命名和复制数据

时间：2016-02-11 15:59:43

标签： excel vba excel-vba

我在这里已经是一个沉默的读者几个月，但现在已经在这个代码上苦苦挣扎了一个星期，所以我想如果有人能帮忙的话。

我有一张工作表，其中第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

我投入了＃34; NEWSHEET＆＃34;看看是否创建了新的工作表，但它仍然失败。我只是看不出我哪里出错了。

欢迎任何帮助/建议。

编辑。

我无法解决原因。 最后一个col将是H4，所以lastcol将是＆＃34; 8＆＃34; 。 然后对于i = 4到8运行循环。在第4行的每个单元格中都有描述，所以我不明白为什么它会在瞬间工作然后失败？

我不知道这是否会让它变得更容易，但我想要在单元格C4中创建的纸张数量，所以我可以使用它而不是查找填充的单元格。所以如果C4是2那么我想添加2张名为D4，E4的内容。如果C4为3，那么我想添加3张名称作为D3，E3，F3的内容。我是否比我需要的更难？

UPDATE 我发现信息的复制正在影响这个循环。并将代码修改为此。

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)


    .Rows(13).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

这就是我希望它做几件小例外的事情。 表格由D1中的单元格命名，然后是E13，F13，G13，H13。所以我需要弄清楚信息的来源。 最后一点是由于我在第一张表中的条件格式，我在复制单元格中的黑色背景上获得文本，但这是我最担心的！ UPDATE 发现错误 - 

    sShtName = ActiveSheet.Cells(4, i).Value2

应该是

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

3 个答案:

答案 0 :(得分：0)

您正在错误地调用您的手机。使用(4, i)代替(4 & i)。

您调用它的方式将其连接到43，这导致您检查工作表引用的单元格AQ1（AQ是第43列）。

编辑：我刚刚走了一段路，发现了其他一些错误。您需要在“存在”功能中将工作表名称设置为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

答案 1 :(得分：0)

您可以使用更短的方式（见下文），而不是添加新工作表，然后将活动工作表设置为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

答案 2 :(得分：0)

这是我的最终代码。有一些调整，首先我在第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
相关问题
最新问题