Wps VBA编程问题

Question

您好，我遇到一个问题，我想用VBA编程做一个自动更新和自动同步的功能，但是，我发现我总不能输出相应的行；然后显示图片显示的问题；您能帮我找一下原因吗？

Private nextLeft As Double
Private nextTop As Double

Private Sub UserForm_Initialize()
    ' 初始化位置
    nextLeft = 10
    nextTop = 100 ' 调整初始位置以腾出顶部空间用于输入源表信息
End Sub

Private Sub btnAddControls_Click()
    AddControls
End Sub

Private Sub AddControls()
    ' 计算现有控件数量，减去初始的6个控件：两个标签、两个文本框、两个按钮
    Dim ctrlIndex As Integer
    ctrlIndex = (Me.Controls.Count - 6) / 2 + 1
    
    ' 添加复合框
    Dim comboBox As MSForms.comboBox
    Set comboBox = Me.Controls.Add("Forms.ComboBox.1", "comboBox" & ctrlIndex, True)
    With comboBox
        .Left = nextLeft
        .Top = nextTop
        .Width = 100
        .Height = 20
    End With
    
    ' 填充复合框内容
    Dim tableNames As Collection
    Set tableNames = GetTableNames()
    Dim i As Integer
    For i = 1 To tableNames.Count
        comboBox.AddItem tableNames(i)
    Next i
    
    ' 添加文本框
    Dim textBox As MSForms.textBox
    Set textBox = Me.Controls.Add("Forms.TextBox.1", "textBox" & ctrlIndex, True)
    With textBox
        .Left = nextLeft + 110
        .Top = nextTop
        .Width = 100
        .Height = 20
    End With
    
    ' 更新下一个控件的位置
    If nextLeft + 220 > Me.InsideWidth Then
        ' 如果超出宽度，则换行
        nextLeft = 10
        nextTop = nextTop + 30
    Else
        ' 否则向右移动
        nextLeft = nextLeft + 220
    End If
End Sub

Private Function GetTableNames() As Collection
    Dim ws As Worksheet
    Set GetTableNames = New Collection
    For Each ws In ThisWorkbook.Worksheets
        GetTableNames.Add ws.Name
    Next ws
End Function

Private Sub btnFetchData_Click()
    AutoFillData
End Sub

Private Sub AutoFillData()
    Dim sourceSheet As Worksheet
    Dim sourceRange As Range
    Dim targetSheet As Worksheet
    Dim targetColumn As Range
    Dim nextEmptyCell As Range
    Dim ctrl As Control
    Dim comboBox As MSForms.comboBox
    Dim textBox As MSForms.textBox
    Dim sourceCell As Range
    
    ' 获取源表和源区域
    On Error Resume Next
    Set sourceSheet = ThisWorkbook.Sheets(Me.txtSourceSheet.Text)
    Set sourceRange = sourceSheet.Range(Me.txtSourceRange.Text)
    On Error GoTo 0
    
    If sourceSheet Is Nothing Or sourceRange Is Nothing Then
        MsgBox "请检查源表名称和源区域输入是否正确。", vbExclamation
        Exit Sub
    End If
    
    ' 遍历所有控件
    For Each ctrl In Me.Controls
        If TypeName(ctrl) = "ComboBox" And Left(ctrl.Name, 8) = "comboBox" Then
            Set comboBox = ctrl
            ' 解析出对应的文本框名称
            Dim textBoxName As String
            textBoxName = "textBox" & Mid(comboBox.Name, 9)
            
            ' 找到对应的文本框
            On Error Resume Next
            Set textBox = Me.Controls(textBoxName)
            On Error GoTo 0
            
            If textBox Is Nothing Then
                MsgBox "找不到对应的文本框：" & textBoxName, vbExclamation
            Else
                ' 检查目标表和目标列是否有效
                If comboBox.Value <> "" And textBox.Text <> "" Then
                    On Error Resume Next
                    Set targetSheet = ThisWorkbook.Sheets(comboBox.Value)
                    Set targetColumn = targetSheet.Range(textBox.Text)
                    On Error GoTo 0
                    
                    If targetSheet Is Nothing Or targetColumn Is Nothing Then
                        MsgBox "请检查目标表名称和目标列输入是否正确。", vbExclamation
                    Else
                        ' 复制数据到目标列
                        For Each sourceCell In sourceRange
                            If Not IsEmpty(sourceCell.Value) Then
                                Set nextEmptyCell = targetColumn.Cells(targetColumn.Cells.Count).End(xlUp).Offset(1, 0)
                                nextEmptyCell.Value = sourceCell.Value
                            End If
                        Next sourceCell
                    End If
                End If
            End If
        End If
    Next ctrl
End Sub

Sub ShowAddControlsForm()
    UserForm1.Show
End Sub

Answer 1

以下回复参考：皆我百晓生、券券喵儿等免费微信小程序作答:

根据您提供的代码和描述，我将为您分析问题并提出解决方案。我会先从可能的问题出发，再给出修正的代码。

问题分析：

1. 输出问题：

您提到无法输出相应的行，这可能是因为在AutoFillData方法中，处理源数据复制的逻辑可能存在问题。特别是在确定目标列和复制数据到目标列的部分。需要确保目标列的确定是正确的，并且正确地处理了源数据的复制逻辑。

2. 图片显示问题：

对于图片显示的问题，我需要更多的信息来判断问题的原因。可能是图片路径问题、图片格式问题或者是代码中的逻辑问题导致的。不过，从您提供的代码中并没有看到与图片显示直接相关的代码部分。

修正建议：

对于AutoFillData方法中的问题，您可以尝试以下修改：

修改目标列的确定和复制逻辑：

在您的代码中，确定目标列是通过文本框输入的列名和在当前工作表中找到这个列来完成的。然而，这种方法假设用户输入的列名在目标工作表中是唯一的。如果工作表中有多个列具有相同的名称，这种方法可能会出错。因此，建议通过更明确的方式来确定目标列，例如使用列的位置或者列索引来确定目标列。同时，您还应该检查目标列的宽度和源数据的类型是否匹配，以避免在复制过程中出现错误。以下是一个简化并修正的示例：

Private Sub AutoFillData()
    Dim sourceSheet As Worksheet
    Dim sourceRange As Range
    Dim targetSheet As Worksheet
    Dim targetColumn As Range
    Dim ctrl As Control
    Dim comboBox As MSForms.ComboBox
    Dim targetColumnCell As Range
    Dim i As Integer
    Dim targetIndex As Integer  ' 目标列的索引位置（假设是列字母）或位置（数字）
    Dim sourceCell As Range
    Dim nextEmptyCell As Range  ' 目标列的下一个空单元格位置用于插入数据
    Dim isFound As Boolean  ' 用于检查是否找到了正确的目标列位置或单元格位置用于插入数据
    Dim targetColumnWidth As Integer  ' 用于检查目标列的宽度是否足够容纳源数据的大小（字符数）等参数的设置和调整。此处仅提供一个思路性的代码片段，具体实现需要根据您的实际需求进行调整和优化。如果需要使用更复杂的逻辑（例如检查多个列标题匹配的情况），需要进一步细化处理逻辑或调整数据结构来满足实际需求。如果需要更具体的帮助或有其他问题，请提供更多详细信息或描述具体的场景和需求。