0
我在這裏幾個月一直是一個沉默的讀者，但一直在努力與此代碼一個星期了，所以想我會看看是否有人可以幫助。動態表命名和複製數據
我有一個工作表，其中工作表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
我把「NEWSHEET」，看看，甚至創建了一個新的工作表，但它仍然失敗。我只是不知道我要去哪裏錯了。
歡迎任何幫助/建議。
編輯。
我無法解決，爲什麼。 最後一個col將是H4，因此lastcol將是「8」。 然後爲i = 4到8運行循環。在第4行的每個單元格中都有描述，所以我不明白它爲什麼會在2瞬間工作然後失敗？
我不知道這是否會使它更容易，但我有我希望在單元格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
如果我的回答對您有所幫助，請把它標記爲接受的答案。如果沒有，讓我知道我可以幫助更多。 – JMcD
HI JMcD這是一個偉大的現在我需要解決如何使用單元格D4中的信息重命名工作表，以及用E4中的信息重新編寫信息等。 –
這可能會有所幫助你將該名稱設置爲一個變量，因爲你將在多個地方使用它。我將更新上面的代碼示例以顯示我的意思。 – JMcD