分隔的单元格扩展

Question

我是VBA的新手，所以在此先感谢您的建议。我只是在帮忙一个朋友，以减少我的业余时间的重复性。

我创建了一个GUI，该GUI具有2个ListBox，其中包含excel文件中工作表的名称。左边的ListBox包含可用的工作表，右边的ListBox是用户选择进行分析的工作表的列表，并能够在两个ListBox之间移动名称。我试图将GUI链接到我创建的执行实际分析的模块。链接后，我需要在GUI中进行选择以成为可以在模块中循环通过的数组。我缺少了几块，所以请多多包涵。

提交按钮代码：

Dim Size As Integer 
Size = Me. ListBox2 . ListCount - 1 
ReDim Selection(0 To Size) As String
Dim i As Integer

For i = 0 To Size 
    Selection (i) = Me.ListBox2.ItemData(i) 
Next i 

Unload GUI

我要实现选择的模块区域：

'Only performs copy/paste actions on the worksheets that aren't named "Summary".
    For Each sh In ActiveWorkbook. Worksheets 
        If sh.Name < > DestSh.Name Then 
'Sets the Range you want to Copy from the source Worksheets. This range is the set of cells with data in it.
            Set CopyRng = sh. UsedRange

目标是从GUI中读取选区，找到以其命名的工作表，然后将选区以某种方式链接到“ sh”变量。

Answer 1

由于您已经在代码中将<?php echo 'Hello World'; ?>引用为工作表变量，而sh数组包含字符串，因此我认为最简单的方法是将Selections语句转换为：

For..Each

并添加以下行：

For Each sel_item In Selection

当然，您还需要将Set sh = ActiveWorkbook.Worksheets(sel_item)语句编辑为Next sh，并添加一个Next sel_item

换句话说，循环部分的开始看起来像：

Dim sel_item as Variant

代替此（原始）：

'Only performs copy/paste actions on the worksheets that aren't named "Summary".
    For Each sel_item In Selection
        Set sh = ActiveWorkbook.Worksheets(sel_item)
        If sh.Name < > DestSh.Name Then 
'Sets the Range you want to Copy from the source Worksheets. This range is the set of cells with data in it.
            Set CopyRng = sh. UsedRange

Answer 2

分隔的单元格扩展

首先调整常量部分中的值，然后通读整个注释，因为可能会遇到一些意想不到的问题。您可以在任何包含逗号作为分隔符的列上使用它，因此，在您的情况下，也可以在基本列上使用它。

Sub DelimitedCellExpansion()

  Const cVntWsSource As String = "Sheet1"   ' Source Worksheet Name/Index
  Const cStrSourceFirst As String = "A1"    ' Source First Cell Range of Data
  Const cVntSplit As Variant = "D"          ' Source Column Letter/Number
  Const cVntWsTarget As String = "Sheet2"   ' Target Worksheet Name/Index
  Const cStrTargetFirst As String = "B1"    ' Target First Cell Range of Data

  Const cStrSep  As String = ",,,|,,|, ,"   ' Wrong Separators

  Dim vntSrc As Variant       ' Source Array
  Dim vntSep As Variant       ' Separator Array
  Dim vntSplitData As Variant ' Split Data Array
  Dim vntSplit As Variant     ' Split Array
  Dim vntCol As Variant       ' Target Column Array
  Dim vntTgt As Variant       ' Target Array

  Dim intCol As Integer       ' Source Array Target Column
  Dim lng1 As Long            ' Source Array Target Column Rows Count(er)
  Dim int1 As Integer         ' Separator Array Strings Counter
  Dim lng2 As Long            ' Target Array Rows Count(er)
  Dim int2 As Integer         ' Split Data Column Counter

  ' Source Worksheet Data Extraction
  With ThisWorkbook.Worksheets(cVntWsSource)
    If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
        Is Nothing Then   ' Worksheet has data.
      ' Paste Source Range into Source Array
      vntSrc = .Range(cStrSourceFirst, .Cells(.Cells.Find("*", , , , 1, 2) _
          .Row, .Cells.Find("*", , , , 2, 2).Column))
      ' Calculate Source Array Target Column.
      intCol = .Columns(cVntSplit).Column - .Range(cStrSourceFirst).Column + 1
     Else                 ' Worksheet is empty.
      GoTo EmptySheetErr
    End If
  End With

  ' Split Separator String into Separator Array.
  vntSep = Split(cStrSep, "|")

  ' Introduce Split Data Array
  ReDim vntSplitData(1 To UBound(vntSrc))

  ' Target Array Columns Count
  For lng1 = 1 To UBound(vntSrc)
    ' Clean separators in current field of Target Column.
    vntSrc(lng1, intCol) = WorksheetFunction.trim(vntSrc(lng1, intCol))
    For int1 = 0 To UBound(vntSep)
      vntSrc(lng1, intCol) = Replace(vntSrc(lng1, intCol), _
          vntSep(int1), ",")
    Next
    ' Split current field of Target Column.
    vntSplit = Split(vntSrc(lng1, intCol), ",")
    ' Resize Target Column Array.
    If Not IsEmpty(vntCol) Then
      ReDim Preserve vntCol(1 To UBound(vntCol) + UBound(vntSplit) + 1)
     Else
      ReDim vntCol(1 To UBound(vntSplit) + 1)
    End If
    ' Copy split values to Target Column Array.
    For int1 = 0 To UBound(vntSplit)
      vntCol(UBound(vntCol) - UBound(vntSplit) + int1) = trim(vntSplit(int1))
    Next
    ' Collect Split Data.
    vntSplitData(lng1) = UBound(vntSplit) + 1
  Next

  Erase vntSplit
  Erase vntSep

  ' Write data to Target Array
  lng2 = 1
  ReDim vntTgt(1 To UBound(vntCol), 1 To UBound(vntSrc, 2))
  For lng1 = 1 To UBound(vntSrc)
    ' Write current row of other columns to Target Array.
    Select Case intCol
      Case 1 ' LBound(vntSrc, 2)
        For int1 = 2 To UBound(vntSrc, 2)
          vntTgt(lng2, int1) = vntSrc(lng1, int1)
        Next
      Case UBound(vntSrc, 2)
        For int1 = 1 To UBound(vntSrc, 2) - 1
          vntTgt(lng2, int1) = vntSrc(lng1, int1)
        Next
      Case Else
        For int1 = 1 To intCol - 1
          vntTgt(lng2, int1) = vntSrc(lng1, int1)
        Next
        For int1 = intCol + 1 To UBound(vntSrc, 2)
          vntTgt(lng2, int1) = vntSrc(lng1, int1)
        Next
    End Select
    ' Write current row of Source Array Target Column to Target Array.
    For int2 = 1 To vntSplitData(lng1)
      vntTgt(lng2, intCol) = vntCol(lng2)
      lng2 = lng2 + 1
    Next
  Next
  Erase vntCol

'  With ThisWorkbook.Worksheets(cVntWsTarget)
'  ' Paste Target Array into Target Worksheet.
'    .Range(cStrTargetFirst).Resize(UBound(vntTgt), UBound(vntTgt, 2)) = vntTgt
'  End With

  ' This would have been the end, if there was no formatting to do.

  ' Introducing a Range object.
  Dim objRng As Range
  Set objRng = ThisWorkbook.Worksheets(cVntWsTarget) _
      .Range(cStrTargetFirst).Resize(UBound(vntTgt), UBound(vntTgt, 2))

'***************************************
' This is necessary if there are merged cells in the Target Range.
' This clears the whole Target Worksheet.
  objRng.Parent.Cells.Clear
' This clears only the Target Range.
'  objRng.Cells.Clear
'***************************************

  ' Paste Target Array into Target Range of  Target Worksheet.
  objRng = vntTgt
  Erase vntTgt

  With objRng
    ' Paste formatting from first row down to the last.
    .Cells(1, 1).Resize(, .Columns.Count).Copy ' Copy first row.
    .PasteSpecial Paste:=xlPasteFormats        ' Paste formatting down to last.
    ' The Target Range is selected and is flickering. Therefore:
    Application.CutCopyMode = False ' Target Range still selected.

'***********************************************************
    ' Apply formatting (merge)
'***********************************************************

' This is up to you. I have done only some easy formatting.

'    With .Interior
'      .ColorIndex = xlNone
'      .Pattern = xlSolid
'      .PatternColorIndex
'    End With

'    ' Font
'    With .Font
'      .Name = "Verdana"
'      .Size = 10
'      .Strikethrough = False
'      .Superscript = False
'      .Subscript = False
'      .OutlineFont = False
'      .Shadow = False
'      .Underline = xlUnderlineStyleNone
'      .ColorIndex = xlAutomatic
'      .Bold = True
'    End With

' Borders
    With .Borders(xlEdgeLeft)
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = xlAutomatic
    End With
    With .Borders(xlEdgeTop)
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = xlAutomatic
    End With
    With .Borders(xlEdgeBottom)
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = xlAutomatic
    End With
    With .Borders(xlEdgeRight)
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = xlAutomatic
    End With
    With .Borders(xlInsideVertical)
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = xlAutomatic
    End With
    With .Borders(xlInsideHorizontal)
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = xlAutomatic
    End With

    lng2 = 1
    For lng1 = 1 To UBound(vntSrc)
      ' Write current row of other columns to Target Array.
      Select Case intCol
        Case 1 ' LBound(vntSrc, 2)
          For int1 = 2 To UBound(vntSrc, 2): GoSub OtherFormat: Next
        Case UBound(vntSrc, 2)
          For int1 = 1 To UBound(vntSrc, 2) - 1: GoSub OtherFormat: Next
        Case Else
          For int1 = 1 To intCol - 1: GoSub OtherFormat: Next
          For int1 = intCol + 1 To UBound(vntSrc, 2): GoSub OtherFormat: Next
      End Select
      GoSub TargetFormat
      lng2 = lng2 + vntSplitData(lng1)
    Next

    Erase vntSplitData
    Erase vntSrc

    GoTo FormatEnd
'***********************************************************
' This is created to easily adjust (change) formatting.
' The formatting applies only to the Data range.
'***********************************************************
OtherFormat:    ' Format other columns.
  With .Cells(lng2, int1).Resize(vntSplitData(lng1))
    If vntSplitData(lng1) > 1 Then  ' Multiple rows.
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .WrapText = False
      .Orientation = 0
      .AddIndent = False
      .IndentLevel = 0
      .ShrinkToFit = False
      .ReadingOrder = xlContext
      .MergeCells = True
     Else                           ' One row only.
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlBottom
      .WrapText = False
      .Orientation = 0
      .AddIndent = False
      .IndentLevel = 0
      .ShrinkToFit = False
      .ReadingOrder = xlContext
      .MergeCells = False
    End If
  End With
  Return
TargetFormat:   ' Format Target Column.
  With .Cells(lng2, intCol).Resize(vntSplitData(lng1))
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
  End With
  Return
FormatEnd:

    ' Only autofits the Target Range.
'    .Columns.AutoFit
    ' Autofit from top.
    .Columns.EntireColumn.AutoFit

'***********************************************************

  End With

ProcedureExit:
  Set objRng = Nothing
Exit Sub

EmptySheetErr:
  MsgBox "You're in an empty sheet."
  GoTo ProcedureExit

End Sub

VBA使用列表框将选择内容应用于模块

2 个答案:

分隔的单元格扩展