Question

我正在尝试按列名复制特定列并将其复制到新工作表。我在网上找到了这个代码，但是我希望在vba代码中找到cloumn名称，而不是弹出一个文本框，我一次写入每个代码。

子副本列（）

 Dim strColRng As String
 Dim strSheetName As String
 Dim intNoofCols As Integer
 Dim strColName() As String
 Dim strCurSheetName As String

 'To get the No. of Columns Available to Search
 intRng = 65

 'To get the No. of Columns to copy and paste
 intNoofCols = 10

 'To set size of the Array
 ReDim Preserve strColName(intNoofCols)
 For i = 0 To intNoofCols - 1
     'To Get the Column Name to Search
    strColName(i) = Array(Array("POS", "POS"), Array("Product Code", "Product Code"), Array("Product Name", "Product Name"), Array("Currency", "Currency"), Array("Nominal Source", "Nominal Source"), Array("Maturity Date", "Maturity Date"), Array("Nominal USD", "Nominal USD"), Array("BV Source", "BV Source"), Array("ISIN", "ISIN"), Array("Daily NII USD", "Daily NII USD"))
   ' InputBox("Enter the Column Name to Copy?", "Column Name")


 Next

'To get the Sheet Name to paste the content
 strSheetName = InputBox("Enter the Sheet Name to Paste?", "Sheet Name")

 'To store the Current Sheet Name where to copy

 strCurSheetName = ActiveSheet.Name

 For j = 0 To intNoofCols - 1 'To get the Column Names from the Array

       For i = 1 To intRng

             'To Select the Sheet which column to copy
             Sheets(strCurSheetName).Select

               'Store the Cell Value
             strVal = Cells(1, i)

             'Check the Value with the User given column name
             If UCase(strVal) = UCase(Trim(strColName(j))) Then

                     'Select and Copy
                      Cells(1, i).Select
                      Range(Selection, Selection.End(xlDown)).Select
                      Selection.Copy

                     'Select and Paste
                     Sheets(strSheetName).Select
                     Cells(1, j + 1).Select
                     Range(Selection, Selection.End(xlDown)).PasteSpecial xlPasteValues
                '     ActiveSheet.Paste
              End If
       Next
  Next

我感谢任何帮助。谢谢！

Answer 1

因此，如果我理解正确，您希望strColName变量保存您定义的数组，而不是程序循环并要求用户填充数组？在这种情况下，请使用：

Dim strColName() As String
strColName = Split("POS,Product Code,Product Name,Currency,Nominal Source,Maturity Date,Nominal USD,BV Source,ISIN,Daily NII USD", ",")

问题是，您将strColName定义为字符串数组，并输入数组。此外，您在循环内定义了数组，因此它将执行10次。您可以删除redim语句，因为您在创建数组时定义了数组的成员数。

Answer 2

我一直都在使用这个

'1 = DELETE all columns IN list
'2 = DELETE all columns NOT in list
'3 = MOVE all columns IN List to NEW Sheet
'4 = MOVE all columns NOT in List to NEW Sheet
'sSource = Source Sheet for Deleting or Moving To
'tTarget = Target Sheet for Moving Columns To
'n = offset the numer of columns when moving columns n = 0 for no offset
Sub MoveOrDelete()

  fDeleteOrMove 3, "MySheetNameSoure", "MySheetNameTarget", 0, Array("ColName1", "ColName2", "ColName3")

End Sub

'THIS IS THE FUNCTION FOR MOVE/DELETE
Sub fDeleteOrMove(cWhat As Integer, sSource As String, tTarget As String, n As Integer,    myList As Variant)
Dim wsS As Excel.Worksheet
Dim wsT As Excel.Worksheet
Dim LC As Long
Dim mycol As Long
Dim x

ActiveWorkbook.Worksheets(sSource).Select
  Set wsS = ActiveWorkbook.Worksheets(sSource)  'Source Sheet for Deleting or Moving To
  Set wsT = ActiveWorkbook.Worksheets(tTarget)  'Target Sheet for Moving Columns To

'Get Last Row of "Source" Sheet
LC = wsS.Cells(1, Columns.Count).End(xlToLeft).Column

For mycol = LC To 1 Step -1
    x = ""
    On Error Resume Next
    x = WorksheetFunction.match(Cells(1, mycol), myList, 0)

   Select Case cWhat
   Case 1
      'Delete all columns IN list
        If IsNumeric(x) Then wsS.Columns(mycol).EntireColumn.Delete
   Case 2
       'Delete all columns NOT in list
         If Not IsNumeric(x) Then wsS.Columns(mycol).EntireColumn.Delete
   Case 3
       'Move all columns IN List to NEW Sheet
         If IsNumeric(x) Then wsS.Columns(mycol).EntireColumn.Copy _
                                 Destination:=wsT.Columns(x).Offset(, n)
   Case 4
       'Move all columns NOT in List to NEW SheeT
         If Not IsNumeric(x) Then wsS.Columns(mycol).EntireColumn.Copy _
                                     Destination:=wsT.Columns(mycol).Offset(, n)
           'Delete the EMPTY columns that were not moved from "Target" sheet
             If IsNumeric(x) Then wsS.Columns(mycol).EntireColumn.Copy _
                                         Destination:=wsT.Columns(mycol).Offset(, n).Delete

  End Select
Next mycol
ActiveWorkbook.Worksheets(tTarget).Select
End Sub

VBA - 按特定名称搜索列而不使用文本框

2 个答案: