進口，文字欄，欄搜索值，

Question

我想創建一個Excel工作表使用VBA，可以讓我做到以下幾點：

1. 用戶點擊命令按鈕1：創建一個新的工作表標籤，提示用戶搜索要導入的excel文件。之後，帶有vba代碼的Excel工作表將標題爲「Importeddata」的工作表導入新創建的工作表選項卡。

2. 用戶點擊commandbutton2：使用文本到柱拆分通過分離在E列項 - （即12332 - 西瓜）

3. 用戶點擊commandbutton3：提示鍵入的項目編號。這之後，Excel查找數列E和進口的所有值到工作表標籤的所有CommandButton控件（工作表Sheet1）

目前，我寫了一些代碼，但它不工作太清楚...謝謝尋求幫助！

下面的代碼：命令按鈕2是錄製的宏（標題爲子TexttoColumns），但它會更好，如果我可以在代碼塊合併它：

Private Sub CommandButton1_Click() 
    Dim wkbCrntWorkBook As Workbook 
    Dim wkbSourceBook As Workbook 
    Dim rngSourceRange As Range 
    Dim rngDestination As Range 
    Set wkbCrntWorkBook = ActiveWorkbook 
    Dim ws As Worksheet 
    Set ws = ThisWorkbook.Sheets.Add(After:= _ 
      ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) 
    ws.Name = "Importeddata" 
    With Application.FileDialog(msoFileDialogOpen) 
     .Filters.Clear 
     .Filters.Add "Excel", "*.xlsx; *.xlsm; *.xlsa" 
     .AllowMultiSelect = False 
     .Show 
     If .SelectedItems.Count > 0 Then 
      Workbooks.Open .SelectedItems(1) 
      Set wkbSourceBook = ActiveWorkbook 
      Set rngSourceRange = Application.InputBox(prompt:="Select source range", Title:="Source Range", Default:="A1", Type:=8) 
      wkbCrntWorkBook.Activate 
      Set rngDestination = Application.InputBox(prompt:="Select destination cell", Title:="Select Destination", Default:="A1", Type:=8) 
      rngSourceRange.Copy rngDestination 
      rngDestination.CurrentRegion.EntireColumn.AutoFit 
      wkbSourceBook.Close False 
     End If 
    End With 
End Sub 



Private Sub CommandButton3_Click() 
Dim LSearchRow As Integer 
    Dim LCopyToRow As Integer 

    On Error GoTo Err_Execute 

    'Start search in row 4 
    LSearchRow = 4 

    'Start copying data to row 2 in Sheet2 (row counter variable) 
    LCopyToRow = 2 

    While Len(Range("A" & CStr(LSearchRow)).Value) > 0 

     'If value in column E = "Mail Box", copy entire row to Sheet2 
     If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then 

     'Select row in Sheet1 to copy 
     Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select 
     Selection.Copy 

     'Paste row into Sheet2 in next row 
     Sheets("Sheet2").Select 
     Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select 
     ActiveSheet.Paste 

     'Move counter to next row 
     LCopyToRow = LCopyToRow + 1 

     'Go back to Sheet1 to continue searching 
     Sheets("Sheet1").Select 

     End If 

     LSearchRow = LSearchRow + 1 

    Wend 

    'Position on cell A3 
    Application.CutCopyMode = False 
    Range("A3").Select 

    MsgBox "All matching data has been copied." 

    Exit Sub 

Err_Execute: 
    MsgBox "An error occurred." 
End Sub 

Sub TexttoColumns() 
' 
' TexttoColumns Macro 
' 
' Keyboard Shortcut: Ctrl+t 
' 
    Sheets("Gen6 Data").Select 
    Columns("E:E").Select 
    Selection.TexttoColumns Destination:=Range("E1"), DataType:=xlDelimited, _ 
     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ 
     Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _ 
     :="-", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True 
    Sheets("Sheet1").Select 
End Sub 

Answer 1

仍不能確定具體是什麼不適合你。但是，CommandButton1似乎對我來說工作正常。如果沒有關於texttocolumns的數據/信息，我對此沒有任何反饋。
你可以清理CommandButton3一點。也許這樣的事情：

Private Sub CommandButton3_Click() 
Dim LSearchRow As Integer 
    Dim LCopyToRow As Integer 

    On Error GoTo Err_Execute 

    'Start search in row 4 
    LSearchRow = 4 

    'Start copying data to row 2 in Sheet2 (row counter variable) 
    LCopyToRow = 2 

    While Len(Range("A" & LSearchRow).Value) > 0 

     'If value in column E = "Mail Box", copy entire row to Sheet2 
     If Sheets("Sheet1").Range("E" & LSearchRow).Value = "Mail Box" Then 

     'Select row in Sheet1 to copy 
     Rows(LSearchRow).EntireRow.Copy Sheets("Sheet2").Rows(LCopyToRow) 

     'Move counter to next row 
     LCopyToRow = LCopyToRow + 1 

     End If 

     LSearchRow = LSearchRow + 1 

    Wend 

     MsgBox "All matching data has been copied." 

    Exit Sub 

Err_Execute: 
    MsgBox "An error occurred." 
End Sub