英文:
VBA inserting data where it should not
问题
' 创建一个VBA，将具有相同结构的4个工作表中的数据复制到另一个工作表中。在该工作表中，我有额外的两列YearMonth和SourceSheet。SourceSheet列应包含数据来自于哪个4个工作表中的信息，yearmonth是根据计算工作表的单元格F1中选择的月份填充的。问题在于，yearmonth和sourcesheet列继续将数据放在它们不应该存在的地方。例如，第298行是最后一行，除了sourcesheet和yearmonth之外，所有其他列都正常，但由于某种原因，它们继续到第400行左右。
' 我主要使用chatgpt寻求帮助，因为我是VBA的初学者，它仍然给我提供了具有相同问题的代码。你能告诉我错在哪里吗？
' 以下是代码：
Sub CopyDataToDataSheet()
'...（以下代码未提供，可以在此处添加）
End Sub
英文:
So Im trying to create a VBA that copies data from 4 sheets that have the same structure into another sheet and in that sheet I have extra two columns YearMonth and SourceSheet. The sourcesheet column should contain info from which of the 4 sheets the data is from and yearmonth is populated based on the selected month from cell F1 of calculation sheet. Problem is that the yearmonth and sourcesheet columns continue putting data all the way down where they shouldn't be. So for example row 298 is the last one and all other columns are fine except the sourcesheet and yearmonth which continue to row 400 something for some reason.
Im mainly using chatgpt for help as Im beginner with VBA and it still gives me a code that has the same issue. Can you help me what is wrong?
The code is:
Sub CopyDataToDataSheet()
Dim dataSheet As Worksheet
Dim inputSheet As Worksheet
Dim calculationSheet As Worksheet
Dim lastRow As Long
Dim yearMonthValue As Variant
Dim confirmation As Integer
Dim yearMonthColumn As Range
Dim sourceSheetColumn As Range
Dim dataRange As Range
Dim sourceSheetNames As Variant
Dim dataLastRow As Long`
' Set the data sheet
Set dataSheet = ThisWorkbook.Worksheets("Data Archive")
' Unfilter the data sheet
If dataSheet.AutoFilterMode Then
dataSheet.AutoFilterMode = False
End If
' Set the calculation sheet
Set calculationSheet = ThisWorkbook.Worksheets("Calculation")
' Find the column index of "SourceSheet" in the data sheet
Set sourceSheetColumn = dataSheet.Rows(1).Find("SourceSheet", LookIn:=xlValues, LookAt:=xlWhole)
' Loop through the input sheets
sourceSheetNames = Array("sheet1", "sheet2", "sheet3", "sheet4")
For Each inputSheet In ThisWorkbook.Worksheets(sourceSheetNames)
' Find the last row in the data sheet
lastRow = dataSheet.Cells(dataSheet.Rows.Count, "A").End(xlUp).Row
' Copy the data from the input sheet to the data sheet
Set dataRange = inputSheet.UsedRange.Offset(1)
dataRange.Copy dataSheet.Cells(lastRow + 1, "A")
' Get the value from cell F1 of the Calculation sheet
yearMonthValue = calculationSheet.Range("F1").Value
' Check if "SourceSheet" column exists
If Not sourceSheetColumn Is Nothing Then
' Find the last row of imported data in column A
dataLastRow = lastRow + dataRange.Rows.Count
' Assign the source sheet name to the "SourceSheet" column in the data sheet for each row
dataSheet.Range(dataSheet.Cells(lastRow + 1, sourceSheetColumn.Column), dataSheet.Cells(dataLastRow, sourceSheetColumn.Column)).Value = inputSheet.Name
' Clear the remaining cells in the "SourceSheet" column below the imported data
dataSheet.Range(dataSheet.Cells(dataLastRow + 1, sourceSheetColumn.Column), dataSheet.Cells(dataSheet.Rows.Count, sourceSheetColumn.Column)).ClearContents
End If
' Find the column index of "YearMonth" in the data sheet
Set yearMonthColumn = dataSheet.Rows(1).Find("YearMonth", LookIn:=xlValues, LookAt:=xlWhole)
' Check if "YearMonth" column exists
If Not yearMonthColumn Is Nothing Then
' Assign the yearMonthValue to the "YearMonth" column in the data sheet for each row
dataSheet.Range(dataSheet.Cells(lastRow + 1, yearMonthColumn.Column), dataSheet.Cells(dataLastRow, yearMonthColumn.Column)).Value = yearMonthValue
' Clear the remaining cells in the "YearMonth" column below the imported data
dataSheet.Range(dataSheet.Cells(dataLastRow + 1, yearMonthColumn.Column), dataSheet.Cells(dataSheet.Rows.Count, yearMonthColumn.Column)).ClearContents
End If
' Delete the data from the input sheet
' dataRange.ClearContents
Next inputSheet
' Display success message
MsgBox "Data imported successfully."
End Sub`
</details>
# 答案1
**得分**: 0
这是您提供的代码的翻译部分：
```vba
不清楚为什么你的结果差了数百行。您的数据可能存在一些奇怪的问题。有时在Excel中，当使用VBA中的“UsedRange”时，会捕获到不可见的数据或格式。因此，您可以尝试使用“ReallyUsedRange”函数，而不是`inputSheet.UsedRange`。例如，请参考这里：[getting-the-actual-usedrange](https://stackoverflow.com/questions/7423022/getting-the-actual-usedrange)
我在下面放置了代码的新版本。
关于ChatGPT的代码的一些想法：
- 验证应该放在代码的早期，而不是在循环内部。因此，如果无法解析列索引，就不需要开始循环。
- 您需要始终让用户知道什么时候出现了问题（即，如果验证失败）。
- 另外，验证似乎有点武断 - 列经过验证，但未验证其他工作表是否存在，或者是否找到了正确的年份-日期值，或者输入数据是否具有正确的形状（列数）。也许所有这些都与ChatGPT的“指令”有关。
- 复制的数据的行计数根本不起作用。
- 它也没有正确处理空的输入工作表。
- 我没有看到清除数据的理由，因为根据定义，它进入了最后一行，下面没有数据。
- 如上所述，如果不小心使用“UsedRange”，它有点不可靠。
- 我们的工作似乎仍然安全，至少目前如此：）尽管如此，ChatGPT的发展令人印象深刻，所以继续关注ChatGPT的发展。
新代码：
Sub CopyDataTowsTarget()
Dim wsTarget As Worksheet
Dim wsSource As Worksheet
Dim yearMonth As Variant
Dim i As Long
Dim j As Long
Dim r As Range
Dim s_col As Long
Dim y_col As Long
Dim arr
'先决条件
'名为DataArchive的工作表，具有A、B、C、D、SourceSheet、YearMonth列以及单元格A2:D10中的一些随机数据。
'名为Calculation的工作表，单元格F1中有'2023-05'。
'四个工作表sheet1、sheet2、sheet3、sheet4，其中单元格A2:D10中有随机数据（可能多或少几行）。
' 设置数据工作表
Set wsTarget = ThisWorkbook.Worksheets("Data Archive")
' 仅为了在调试时加快进度
'wsTarget.Range("A11:J1000").Clear
If wsTarget.AutoFilterMode Then
wsTarget.AutoFilterMode = False
End If
yearMonth = Worksheets("Calculation").Range("F1").Value
' 获取MonthYear和SourceSheet列索引
Set r = wsTarget.Rows(1).Find("SourceSheet", LookIn:=xlValues, LookAt:=xlWhole)
If r Is Nothing Then
MsgBox "未找到源工作表列！"
Exit Sub
Else
s_col = r.Column
End If
Set r = wsTarget.Rows(1).Find("YearMonth", LookIn:=xlValues, LookAt:=xlWhole)
If r Is Nothing Then
MsgBox "未找到年月列！"
Exit Sub
Else
y_col = r.Column
End If
' 从输入工作表复制数据到存档工作表
arr = Array("sheet1", "sheet2", "sheet3", "sheet4")
For Each wsSource In Worksheets(arr)
i = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
Set r = wsSource.UsedRange.Offset(1)
If r.Rows.Count > 1 Then
Set r = wsSource.UsedRange.Offset(1)
Set r = r.Resize(r.Rows.Count - 1)
r.Copy
wsTarget.Cells(i, "A").PasteSpecial xlPasteValuesAndNumberFormats
wsTarget.Cells(i, s_col).Resize(r.Rows.Count).Value = wsSource.Name
wsTarget.Cells(i, y_col).Resize(r.Rows.Count).Value = yearMonth
' dataRange.ClearContents
End If
Next wsSource
' 显示成功消息
MsgBox "成功导入数据。"
End Sub
如果您的输入工作表没有标题，代码需要进行一些微调。如果您不想粘贴为值，请进行相应调整（我通常使用PasteSpecial与xlPasteValuesAndNumberFormats，因为通常在存档时希望获取原始数据，而不必担心坏的公式引用）。
英文:
Its not clear why you got results off by hundreds of rows. There could be something weird in your data. Sometimes in Excel there is invisible data or even formatting that gets picked up when you use a "UsedRange" in VBA. So you could try bringing in a "ReallyUsedRange" function to use instead of inputSheet.UsedRange. See for example here: getting-the-actual-usedrange
I've put a new version of the code below.
Some thoughts on ChatGPT's code:
- The validation should go earlier in the code, not inside the loop. So if the column indexes can't be resolved, no need to even start the loop.
- You want to always let the user know when things didn't work correctly (i.e., if validation fails).
- Also it seems a little arbitrary with the validation - columns are validated, but not whether other sheets exists, or a correct year-date value is found, or whether input data has the right shape (# of columns). Maybe all that has to do with your "instructions" for ChatGPT though.
- The row counting of the data copied just didn't work.
- It is not handling empty input sheets correctly either.
- I don't see any reason to clear data below the data you copied in to the DataArchive, because by definition that went to the last row and their is no data below it.
- As noted above
UsedRangeis a bit unreliable if you aren't careful and understand how you are using it. - Our jobs appear to be safe still, at least for now
Impressive nonetheless, so continuing to watch where ChatGPT goes.
New Code:
Sub CopyDataTowsTarget()
Dim wsTarget As Worksheet
Dim wsSource As Worksheet
Dim yearMonth As Variant
Dim i As Long
Dim j As Long
Dim r As Range
Dim s_col As Long
Dim y_col As Long
Dim arr
'Prequisites
' Sheet named DataArchive with columns A, B, C, D, SourceSheet, YearMonth and some random data in cells A2:D10
' Sheet named Calculation with '2023-05' in cell F1
' four sheets sheet1, sheet2, sheet3, sheet4 with random data in cells A2:D10 (may be a few more or less rows)
' Set the data sheet
Set wsTarget = ThisWorkbook.Worksheets("Data Archive")
'only to make things go faster while debugging
'wsTarget.Range("A11:J1000").Clear
If wsTarget.AutoFilterMode Then
wsTarget.AutoFilterMode = False
End If
yearMonth = Worksheets("Calculation").Range("F1").Value
' Get the MonthYear and SourceSheet column indexes
Set r = wsTarget.Rows(1).Find("SourceSheet", LookIn:=xlValues, LookAt:=xlWhole)
If r Is Nothing Then
MsgBox "Source Sheet Column not Found!"
Exit Sub
Else
s_col = r.Column
End If
Set r = wsTarget.Rows(1).Find("YearMonth", LookIn:=xlValues, LookAt:=xlWhole)
If r Is Nothing Then
MsgBox "Source Sheet Column not Found!"
Exit Sub
Else
y_col = r.Column
End If
' Copy data from input sheets to Archive sheet
arr = Array("sheet1", "sheet2", "sheet3", "sheet4")
For Each wsSource In Worksheets(arr)
i = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
Set r = wsSource.UsedRange.Offset(1)
If r.Rows.Count > 1 Then
Set r = wsSource.UsedRange.Offset(1)
Set r = r.Resize(r.Rows.Count - 1)
r.Copy
wsTarget.Cells(i, "A").PasteSpecial xlPasteValuesAndNumberFormats
wsTarget.Cells(i, s_col).Resize(r.Rows.Count).Value = wsSource.Name
wsTarget.Cells(i, y_col).Resize(r.Rows.Count).Value = yearMonth
' dataRange.ClearContents
End If
Next wsSource
' Display success message
MsgBox "Data imported successfully."
End Sub
If your input sheets do not have headers, the code needs a little tweaking for that. Also if you don't want the paste to be values adjust as well (I routinely use PasteSpecial with xlPasteValuesAndNumberFormats because usually for archiving you want the raw data without worry about bad formula references.
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库，让每个人都能够通过互相帮助和分享经验来进步。
评论