excelvba随机显示用户表单

我刚刚开始编程VBA，几乎没有其他编程经验

我将首先描述宏的意图：

因此，有x个excel文件，其中包含数据。所有这些文件都遵循相同的基本设计： 列A包含我想要的数据的“名称”。有十行不同的名字。 列M包含与列A的名称对应的数据，以及介于两者之间的列的平均值 此平均数据必须传输到“主”excel文件

我制作了一个userform来选择需要导入的文件，至少在选择文件时效果不错

我使用

usrform.show

如前所述，我能够运行userform。当我在userform中单击apply时，它会停止代码并打开excelvba编辑器并显示图形userform。 不知道是什么原因造成的。你们有什么意见吗

Public strListe_selected() As String
Public booDatenAbbrechen As Boolean

Sub Ergebnisse_einlesen()

Dim datei As String
Dim liste As String
Dim test As Variant
Dim name As String
Dim nPh As Integer
Dim Suche As String
Dim Excel_Daten() As Variant
Dim rngFound As Range
Dim rngFound1 As Range
Dim Komponente() As String
Dim startreihe As Integer
Dim SMK As String
Dim dateinr As Integer
Dim strdatumformatiert As String
Dim strerstellungsdatum() As String
Dim intantwort As Integer
Dim strdatum As String
Dim Phase As String


'*************************************Zeit messen um Einlesezeit zu optimieren
Dim t
t = Now

'*************************************Zeile controlieren, somit kein daten in die falsche zeile kommt
startreihe = ActiveCell.Row
If startreihe < 10 Then
    MsgBox "Bitte markieren sie die Zeile in der die neuen Testdaten eingetragen werden sollen und führen sie das Makro erneut aus"
    Exit Sub
ElseIf Cells(startreihe, 3) <> "" Then
    antwort = MsgBox("Die markierte Zeile enthält bereits Daten, wollen sie diese überschreiben?", vbOKCancel)
    If antwort = vbCancel Then Exit Sub
End If

'************************************Sammeln von Informationen über diese Arbeitsmappe
liste = ThisWorkbook.ActiveSheet.name
letztespalte = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
name = ThisWorkbook.name

'************************************Dialogfenster öffnen
xls_suchen.Show

If booDatenAbbrechen = True Then Exit Sub

For dateinr = 0 To UBound(strListe_selected) 'Schleife über die gewählten xls-Dateien

Application.ScreenUpdating = False                   'Bildschirmanzeige unterdrücken
Workbooks.Open Filename:=Element & strListe_selected(dateinr)  'öffnen der xls-Datei



'**********************************************************************************************************************
'neudimensionieren des ARRAYs
c = 4
emdat = anzkomp * (c + 1)
ReDim Excel_Daten(24 + emdat, 3)

'Spaltenüberschrift des Arrays "Excel_Daten" festlegen
Excel_Daten(0, 0) = "Name"
Excel_Daten(0, 1) = "Reihe"
Excel_Daten(0, 2) = "Spalte"
Excel_Daten(0, 3) = "Wert"

'**********************************************************************************************************************
'******************************** Daten aus der Excel-Datei lesen *******************************************************

i = 2
For k = 1 To anzkomp
    Suche = Komponente(k)
    Excel_Daten(i, 0) = Komponente(k)

    Set rngFound = Cells.Find(What:="Bemerkung:")
    test = Cells(rngFound.Row, rngFound.Column).Value
        If test = "Bemerkung:" Then
        anzkomp = 11
        nPh = 1
        ReDim Komponente(anzkomp)
        Testergebnis = "Phase"
        Komponente(1) = "F_eth"
        Komponente(2) = "F_Lakor_m"
        Komponente(3) = "F_lradap1c[0]"
        Komponente(4) = "F_lradap1c[1]"
        Komponente(5) = "F_lradap1c[2]"
        Komponente(6) = "F_lradap1c[3]"
        Komponente(7) = "F_lradap1c[4]"
        Komponente(8) = "F_lradap1c[5]"
        Komponente(9) = "F_lradap1c[6]"
        Komponente(10) = "F_lradap1c[7]"
        Komponente(11) = "Km_st_1"
    Else
    MsgBox "Der test ist nicht bekannt. Ist der Datei ein EDR Messdatei?"
    End If

    Set rngFound1 = Cells.Find(What:="Phase")
    If rngFound1 Is Nothing Then
       MsgBox Testergebnis & "nicht gefunden"
    Else
        Set rngFound = Cells.Find(What:=Suche, After:=Cells(rngFound1.Row, rngFound1.Column))

        If rngFound Is Nothing Then
             If Suche = "F_eth" Then n = 2
             If Suche = "F_Lakor_m" Then n = 5
             If Suche = "F_lradap1c[0]" Then n = 8
             If Suche = "F_lradap1c[1]" Then n = 11
             If Suche = "F_lradap1c[2]" Then n = 14
             If Suche = "F_lradap1c[3]" Then n = 17
             If Suche = "F_lradap1c[4]" Then n = 20
             If Suche = "F_lradap1c[5]" Then n = 23
             If Suche = "F_lradap1c[6]" Then n = 26
             If Suche = "F_lradap1c[7]" Then n = 29
             If Suche = "Km_st_1" Then n = 32

             For i = n To n + 4
                If i <> n Then Excel_Daten(i, 0) = Suche & "_PH" & i - n
                Excel_Daten(1, 3) = ""

             Next i

        Else
            Excel_Daten(i, 1) = rngFound.Row
            Excel_Daten(i, 2) = rngFound.Column
            Excel_Daten(i, 3) = Cells(rngFound.Row, rngFound.Column + 12).Value
            i = i + 1

                For j = 1 To c
                    If j > nPh Then
                        If Suche = "F_eth" Then n = 2
                        If Suche = "F_Lakor_m" Then n = 5
                        If Suche = "F_lradap1c[0]" Then n = 8
                        If Suche = "F_lradap1c[1]" Then n = 11
                        If Suche = "F_lradap1c[2]" Then n = 14
                        If Suche = "F_lradap1c[3]" Then n = 17
                        If Suche = "F_lradap1c[4]" Then n = 20
                        If Suche = "F_lradap1c[5]" Then n = 23
                        If Suche = "F_lradap1c[6]" Then n = 26
                        If Suche = "F_lradap1c[7]" Then n = 29
                        If Suche = "Km_st_1" Then n = 32
                        Excel_Daten(n + j, 0) = Suche & "_PH" & j
                        Excel_Daten(n + j, 3) = ""
                        i = i + 1
                    End If
                Next j
        End If
     End If

Next k



'Einlesen der Ergebnisse abgeschlossen --> schließen der VTS-Datei
ActiveWorkbook.Close

'**********************************************************************************************
'**********************************************************************************************
'Daten in gewünschtes Tabellenblatt übertragen

For b = 1 To 12
      ThisWorkbook.Worksheets(liste).Cells(startreihe, b + 1) = Excel_Daten(b, 3)
Next b
b = 12
For a = 13 To 10 + emdat

        ThisWorkbook.Worksheets(liste).Cells(startreihe, b + 3) = Excel_Daten(a, 3)
        If Excel_Daten(a, 0) = "GRAMS_KM_CO2" Or Excel_Daten(a, 0) = "GRAMS_MI_CO2" _
        Or Excel_Daten(a, 0) = "FUEL_CONS_MPG" Or Excel_Daten(a, 0) = "FUEL_CONS_KPL" _
       Or Excel_Daten(a, 0) = "FUEL_CONS_LP100K" Then
           b = b
      ElseIf Excel_Daten(a + 1, 0) = Excel_Daten(a, 0) & "_PH1" Then
         b = b + 2
        End If


        For i = 1 To c
            a = a + 1
            b = b + 1
            ThisWorkbook.Worksheets(liste).Cells(startreihe, b + 3) = Excel_Daten(a, 3)
        Next i
        b = b + 1
        'If a < emdat + 10 Then
           ' If test = "US06V1_FE" And VTS_Daten(a + 1, 0) = "FUEL_CONS_MPG" Then B = B + 5
        'End If
Next a

Application.ScreenUpdating = True                  'Bildschirmanzeige zulassen





Next dateinr







End Sub

用户表单：

Private Sub button_cancel_Click()
ReDim strListe_selected(0) 'Liste wird gelöscht
booDatenAbbrechen = True
Unload Me
End Sub

Private Sub button_all_Click()

With Me.ListBox1
    For i = 0 To .ListCount - 1
        ListBox1.Selected(i) = True
    Next
End With

End Sub

Private Sub button_none_Click()

With Me.ListBox1
    For i = 0 To .ListCount - 1
        ListBox1.Selected(i) = False
    Next
End With

End Sub

Private Sub button_apply_Click()
booDatenAbbrechen = False


With Me.ListBox1
liste = .List
j = 0
For i = 0 To .ListCount - 1
    If .Selected(i) Then
        ReDim Preserve strListe_selected(j)
        strListe_selected(j) = liste(i, 0)
        j = j + 1
    End If
Next

End With

Unload Me
End Sub

Private Sub button_add_file_Click()
add_files
End Sub

Private Sub button_add_folder_Click()
add_folder
End Sub



Sub add_folder()

Dim objAppShell As Object
Dim varBrowseDir As Variant
Dim strPfad As String
Dim varUnterordner As Variant
Dim objFileSystem As Object
Dim varOrdner As Variant
Dim Element
Dim strFilelist() As String
Dim i As Integer
Dim strFile As String
Dim FD As FileDialog

Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
    .AllowMultiSelect = True

    If Application.FileDialog(msoFileDialogFolderPicker).Show = 0 Then

    Else
    strPfad = .SelectedItems(1)
End If



End With


If strPfad = "" Then Exit Sub

'Ordner nach *.xls-Dateien durchsuchen
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set varOrdner = objFileSystem.GetFolder(strPfad)
Set varUnterordner = varOrdner.SubFolders

i = 0
ReDim Preserve strFilelist(i)

'Hauptordner durchsuchen
strFile = Dir(strPfad & "\" & "*.xls") 'Ersten Eintrag wählen

Do While strFile <> ""
    strFilelist(i) = strPfad & "\" & strFile
    ListBox1.AddItem (strFilelist(i))
    i = i + 1
        ReDim Preserve strFilelist(i)
    strFile = Dir    'strFile = Dir 'Get nächsten Eintrag.
Loop

'Unterordner durchsuchen
For Each Element In varUnterordner
    strFile = Dir(strPfad & "\" & Element.name & "\" & "*.xls")
    Do While strFile <> ""
        ReDim Preserve strFilelist(i)
        strFilelist(i) = strPfad & "\" & Element.name & "\" & strFile
        ListBox1.AddItem (strFilelist(i))
        i = i + 1
        strFile = Dir    'strFile = Dir 'Get nächsten Eintrag.
    Loop
Next

End Sub

Sub add_files()

Dim FD As FileDialog
Dim Element
Dim i As Integer

Set FD = Application.FileDialog(msoFileDialogOpen)

With FD
.AllowMultiSelect = True
'.InitialFileName = ActiveWorkbook.Path & "\*.xls"""
.Filters.Clear
.Filters.Add "Excel dateien", "*.xls"
End With

i = 1
If FD.Show = -1 Then
    For Each Element In FD.SelectedItems

'       datei = Dir(Element, "*.xls")
        ListBox1.AddItem (FD.SelectedItems(i))
    Next
End If

End Sub

---

您只需复制粘贴代码并选择它，然后使用CTRL+K对其进行格式化即可。。如果这不起作用，您只需将代码添加为文本，我将为您设置格式。我想我们确实需要看看。此外，当它带您到VBE时，是否会突出显示默认黄色的任何代码？您好，谢谢您的回复。不幸的是，它没有突出显示任何内容。。而且，ctrl+k也起了作用：谢谢。我在第一篇文章中添加了代码。请尝试在“应用”按钮中为我更改Unload Me。在模块1中隐藏并卸载usrform。当您使用完它后，我将此Unload usrform放在何处？我像UnloadUserForm一样键入它，因为编辑器建议这样做语句？至少它不再在编辑器中显示usrform。数据不会输入主文件。也许这是我需要解决的另一个问题？