excel VBA在不应插入数据的位置插入数据

vybvopom 于 2023-05-30 发布在其他

关注(0)|答案(1)|浏览(186)

因此，我试图创建一个VBA，复制数据从4张表，具有相同的结构到另一张表，在该表中，我有额外的两列，年月和SourceSheet。源表列应包含数据来自4个工作表中的哪一个工作表的信息，并根据从计算表单元格F1中选择的月份填充年月。问题是yearmonth和sourcesheet列继续将数据一直放在它们不应该在的地方。例如，第298行是最后一行，除了sourcesheet和yearmonth之外，所有其他列都很好，因为某些原因，它们一直延续到第400行。
我主要使用chatgpt的帮助，因为我是VBA的初学者，它仍然给了我一个代码，有同样的问题。你能帮我什么是错的吗？
代码为：

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`

excel

来源：https://stackoverflow.com/questions/76327388/vba-inserting-data-where-it-should-not

1条答案

按热度按时间

fykwrbwg1#

不清楚为什么你得到了数百行的结果。你的数据中可能有一些奇怪的东西。有时在Excel中，当您在VBA中使用“UsedRange”时，会出现不可见的数据甚至格式。所以你可以尝试引入一个“ReallyUsedRange”函数来代替inputSheet.UsedRange。例如，请参见此处：getting-the-actual-usedrange
我在下面放了一个新版本的代码。
关于ChatGPT代码的一些想法：

验证应该在代码的前面进行，而不是在循环内部进行。因此，如果列索引无法解析，甚至不需要启动循环。
您希望总是让用户知道什么时候事情没有正确工作（即，如果验证失败）。
验证似乎也有点随意-列被验证，但不是其他工作表是否存在，或找到正确的年日期值，或输入数据是否具有正确的形状（列数）。也许这一切都与你的“说明”ChatGPT虽然。
复制数据的行计数不起作用。
它也不能正确处理空输入表。
我看不出有什么理由要清除复制到DataArchive中的数据下面的数据，因为根据定义，复制到最后一行的数据下面没有数据。
如上所述，如果您不小心并了解如何使用它，UsedRange有点不可靠。
我们的工作似乎仍然是安全的，至少现在是这样：）尽管如此，令人印象深刻，所以继续关注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
    
'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

如果您的输入工作表没有标题，则需要对代码进行一些调整。另外，如果您不希望粘贴的值被调整（我通常使用PasteSpecial和xlPasteValuesAndNumberFormats，因为通常对于存档，您希望原始数据而不必担心错误的公式引用。

赞(0）回复(0）举报 2023-05-30

我来回答

excel VBA在不应插入数据的位置插入数据

1条答案

相关问题

热门标签

最新问答