Question

我正在尝试查找列并在使用inputbox在特定行上搜索值后复制其值。

我尝试实现的是搜索第7行，但是在所有列中搜索用户在输入框上传递的特定文本（假设为“test”）。如果在第7行找到测试，则列G（例如）我需要将整个G列复制到新工作表或现有工作表。另外，如果在G柱上找到测试，H柱很好被复制，但两者之间没有像A一样粘贴，应粘贴在A和B上。

到目前为止我做了什么：

Private Sub cancel_Click()
    Unload Me
End Sub

Private Sub ok_Click()

    Select Case True
    Case OptionButton1

      Call SearchByName

    Case OptionButton2
        Dim value2 As Variant
        value2 = InputBox("Find the column by characters.", "By characters")
        Unload Me
    Case Else
        MsgBox "You must select an option!"
    End Select

End Sub

Sub SearchByName()

    Dim value1 As Variant
    value1 = InputBox("Find the column by name.", "By name")
    'Unload Me

    Dim Found As Range, LastRow As Long
    Set Found = Rows(7).Find(what:=value1, LookIn:=xlValues, lookat:=xlWhole)
    If Found Is Nothing Then MsgBox "Column couldnt be copyed"

    LastRow = Cells(Rows.Count, Found.Column).End(xlUp).Row

    Dim Coloana As String
    Select Case Found.Column
        Case 1
        Coloana = "A"
        Case 2
        Coloana = "B"
        Case 3
        Coloana = "C"
        Case 4
        Coloana = "D"
        Case 5
        Coloana = "E"
        Case 6
        Coloana = "F"
        Case 7
        Coloana = "G"
        Case 8
        Coloana = "H"
        Case 9
        Coloana = "I"
        Case 10
        Coloana = "J"
        Case 11
        Coloana = "K"
        Case 13
        Coloana = "L"
        Case 14
        Coloana = "M"
        Case 15
        Coloana = "N"
        Case 16
        Coloana = "O"
        Case 17
        Coloana = "P"
    End Select

    Sheets("Sheet1").Range("A1:A" & LastRow).value = Sheets("DAT").Range(Coloana & 1 ":" & Coloana & LastRow).value

End Sub

Private Sub UserForm_Click()

End Sub

新代码，也错了...不知道为什么它没有检查Sheet1下一个空列:(它总是将A列返回为空）

Private Sub cancel_Click()
    Unload Me
End Sub

Private Sub ok_Click()

    Select Case True
    Case OptionButton1

      Call SearchByName

    Case OptionButton2
        Dim value2 As Variant
        value2 = InputBox("Find the column by characters.", "By characters")
        Unload Me
    Case Else
        MsgBox "You must select an option!"
    End Select

End Sub

Sub SearchByName()

    Dim value1 As Variant
    value1 = InputBox("Find the column by name.", "By name")
    Unload Me

    Dim Found As Range, LastRow As Long
    Dim ColoanaToAdd As String
    Dim emptyOne As String
    Dim destination As Worksheet
    Dim emptyColumn As String
    Dim var As String
    Dim Coloana As String

   'With Worksheets("DAT").Range("A1:W500")

    Set Found = Rows(7).Find(What:=value1, LookIn:=xlValues, LookAt:=xlWhole)
    'If Not Found Is Nothing Then
            'firstAddress = Found.Address
            'MsgBox "found" & firstAddress
        'Do

    LastRow = Cells(Rows.Count, Found.Column).End(xlUp).Row

    Select Case Found.Column
        Case 1
        Coloana = "A"
        Case 2
        Coloana = "B"
        Case 3
        Coloana = "C"
        Case 4
        Coloana = "D"
        Case 5
        Coloana = "E"
        Case 6
        Coloana = "F"
        Case 7
        Coloana = "G"
        Case 8
        Coloana = "H"
        Case 9
        Coloana = "I"
        Case 10
        Coloana = "J"
        Case 11
        Coloana = "K"
        Case 13
        Coloana = "L"
        Case 14
        Coloana = "M"
        Case 15
        Coloana = "N"
        Case 16
        Coloana = "O"
        Case 17
        Coloana = "P"
    End Select

    Set destination = Sheets("Sheet1")
    emptyColumn = destination.Cells(7, destination.Columns.Count).End(xlToLeft).Column
    MsgBox "empty coloana" & emptyColumn

    If emptyColumn > 1 Then
        emptyColumn = emptyColumn + 1
    End If

    MsgBox "empty coloana" & emptyColumn

    Select Case emptyColumn
        Case 1
        var = "A"
        Case 2
        var = "B"
        Case 3
        var = "C"
        Case 4
        var = "D"
        Case 5
        var = "E"
        Case 6
        var = "F"
        Case 7
        var = "G"
        Case 8
        var = "H"
        Case 9
        var = "I"
        Case 10
        var = "J"
        Case 11
        var = "K"
        Case 13
        var = "L"
        Case 14
        var = "M"
        Case 15
        var = "N"
        Case 16
        var = "O"
        Case 17
        var = "P"
    End Select

    emptyOne = var & 1 & ":" & var
    MsgBox emptyOne

    ColoanaToAdd = Coloana & 1 & ":" & Coloana
    MsgBox ColoanaToAdd

    Sheets("Sheet1").Range(emptyOne & LastRow).value = Sheets("DAT").Range(ColoanaToAdd & LastRow).value

    MsgBox "Entire column was copyed!"

    'Set Found = .FindNext(Found)
        'Loop While Not Found Is Nothing And Found.Address <> firstAddress
    'End If
   'End With

End Sub

Private Sub OptionButton1_Click()

End Sub

Private Sub UserForm_Click()

End Sub

Answer 1

这是如何运作的

询问用户在第7行搜索的第一个值
如果找到
- 创建新工作表
- 记住搜索到的值
- 将列复制到新工作表中的第一列
- 在初始找到的值之后，在第7行搜索相同的值
  - 如果找到另一个，则复制到新工作表中的下一个可用列
  - 将搜索和复制重复到工作表1上的最后一列
- 询问用户下一个值
  - 如果用户输入已处理的值
    - 确认是否应该再次复制列
    - 如果已经确认，则会再次复制
- 重复此过程，直到用户取消或搜索不存在的值

代码：

Option Explicit

Sub SearchByName()

    Const SRC_ROW   As Long = 7
    Const DELIM     As String = "||"

    Dim oldWS       As Worksheet
    Dim foundCel    As Range

    Set oldWS = Worksheets("Sheet1")

    Set foundCel = findColumn(oldWS.UsedRange.Rows(SRC_ROW))
    If foundCel Is Nothing Then
        MsgBox "Cancelled"
        Exit Sub
    Else
        Dim lastRow As Long
        Dim newWS   As Worksheet
        Dim selCol  As Long
        Dim lastCol As Long
        Dim done    As String
        Dim fndAdr  As String

        Set newWS = getNewWorkSheet("DAT")              'Selected Column(s)
        lastCol = 1
        done = DELIM
        Do
                done = done & foundCel.Value2 & DELIM   'remember all searched values
                selCol = foundCel.Column                'get found column
                lastRow = oldWS.Cells(oldWS.Rows.Count, foundCel.Column).End(xlUp).Row
                copyData oldWS, newWS, lastCol, lastRow, selCol

                fndAdr = foundCel.Address
                Do                                      'find next initial value on row
                    Set foundCel = oldWS.Rows(SRC_ROW).FindNext(foundCel.OFFSET(0, 1))
                    If Not foundCel Is Nothing And foundCel.Address <> fndAdr Then
                        selCol = foundCel.Column        'get found column
                        lastCol = lastCol + 1           'increment next col on new sheet
                        With oldWS                      'get last row
                            lastRow = .Cells(.Rows.Count, foundCel.Column).End(xlUp).Row
                        End With
                        copyData oldWS, newWS, lastCol, lastRow, selCol
                    End If
                Loop While Not foundCel Is Nothing And foundCel.Address <> fndAdr

                Set foundCel = findColumn(oldWS.Rows(SRC_ROW))  'ask for the next value
                If foundCel Is Nothing Then
                    Set foundCel = Nothing                      'user cancelled
                Else
                    'If already processed, confirm re-copy
                    If InStr(1, done, DELIM & foundCel & DELIM) > 0 Then
                        If MsgBox("Copy Again?", vbYesNo, "Processed") = vbNo Then
                            Set foundCel = Nothing
                            Exit Do
                        End If
                    End If
                    lastCol = lastCol + 1   'move to next search
                End If
        Loop While Not foundCel Is Nothing      'stops if canceled or value not found
        newWS.UsedRange.Columns.AutoFit         'resize copied cols for widest text
    End If
End Sub

Public Function getNewWorkSheet(ByVal wsName As String) As Worksheet

    Dim thisWS As Worksheet, activeWS As String

    Application.ScreenUpdating = False              'turn off display
    activeWS = ActiveSheet.Name                     'remember active sheet

    For Each thisWS In ActiveWorkbook.Worksheets    'look for pre-existing sheet
        If thisWS.Name = wsName Then
            Application.DisplayAlerts = False       'turn off sheet deletion warning
            thisWS.Delete                           'if found, delete it
            Application.DisplayAlerts = True
            Exit For
        End If
    Next

    Set thisWS = Worksheets.Add(Sheets(1))          'create a new sheet
    thisWS.Name = wsName                            'rename it

    Worksheets(activeWS).Activate                   'return to previous active sheet
    Application.ScreenUpdating = True
    Set getNewWorkSheet = thisWS
End Function

Public Function findColumn(ByVal srcRow As Range) As Range
    If Not srcRow Is Nothing Then
        Dim srcText As Variant
        srcText = InputBox("Find column by name", "By name")
        If Len(srcText) > 0 Then
            With srcRow
                Set findColumn = .Find(What:=srcText, _
                                       After:=.Cells(1, .Columns.Count), _
                                       SearchDirection:=xlPrevious, _
                                       LookIn:=xlFormulas, _
                                       LookAt:=xlWhole, _
                                       SearchOrder:=xlByRows)
            End With
        End If
    End If
End Function

Public Sub copyData(ByRef oldWS As Worksheet, _
                    ByRef newWS As Worksheet, _
                    ByVal lastCol As Long, _
                    ByVal lastRow As Long, _
                    ByVal selCol As Long)

    Dim col1    As Range
    Dim col2    As Range

    Set col1 = newWS.Range(newWS.Cells(1, lastCol), newWS.Cells(lastRow, lastCol))
    Set col2 = oldWS.Range(oldWS.Cells(1, selCol), oldWS.Cells(lastRow, selCol))

    col2.Copy col1

End Sub

enter image description here

Answer 2

Sub CopyMatchingColumns(inSheet As Worksheet, RowToSearch As Integer, ValueToSearchFor As String)
   Dim cell As Range
   Dim i As Integer
   Dim newsheet As Worksheet

   For i = 1 To inSheet.Columns.Count
      Set cell = inSheet.Cells(RowToSearch, i)
      If cell = ValueToSearchFor Then
         Set newsheet = Sheets.Add()
         cell.EntireColumn.Copy
         newsheet.Range("a1").Select
         newsheet.Paste
      End If
   Next i

End Sub

如何运行它的示例

Sub test()
   CopyMatchingColumns ActiveSheet, 7, "Test"
End Sub

祝你好运！

在按特定行查找完整列后复制整列

2 个答案: