动态场群VBA

Question

我编写了一个简化电子表格的脚本，但我需要有关动态填充字段的帮助。电子表格的当前格式具有不一致的间距，因此难以组合在一起，如果填充的语句仅填充文档的子部分。

我附加了文档的显示方式。

我要做的是根据右侧突出显示的字段填充左侧突出显示的字段。例如（当填写字段“F3”时 - 如果“2012”和“092000”然后在单元格“A4”中从单元格“F2”填充“2012”的BBFY到“A11”停止最后BOC编号“。）在下一个开始相同的过程处理下一组数据。然后，如果有BOC名称2013 092300的新数据，请根据该信息填写相应的信息。

我只是在尝试识别对许多更改的正确调用时遇到困难，这使得很难告诉代码根据新参数更改值。如您所见，F中突出显示的值会发生变化，从而更改下面的相关信息。我已经阻止了我试图启动代码的这一部分。

到目前为止我的代码让我看到了你在下面看到的布局。另外，我试图根据每个部分制作一个新的工作表，但我会尝试再次解决这个问题。

Sub SOFCMacro()

'Begins Macro Optimizations
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   Application.Calculation = xlCalculationManual
   Application.DisplayAlerts = False

'Declarations
   Dim Firstrow As Long
   Dim Lastrow As Long
   Dim Lrow As Long
 Dim rng As Range

'Renames Sheet1 and Make It an Object
  Set Main = ActiveSheet
  Main.Name = "BAR"

'Add and Name Worksheets
  Set WS1 = Sheets.Add
  WS1.Name = "SOFC"

'Clear Formatting
  Sheets("BAR").Activate
  With ActiveSheet
    .Cells.ClearFormats
  End With

***'Comma Diliminate Funding Information
  Sheets("Bar").Activate
  With ActiveSheet
    Set rng = .Range(rng, .Cells(.Rows.Count, rng.Column).End(xlUp))
    For i = Last To 1 Step -1
        If Not IsError(.vaule) Then
            ElseIf (cells(i, "F").value = "092000:"    and "Salaries:" Then cells(Cells, i, "A").value = (Cells(i, "F").Value) Like "20*"
            ElseIf .value = "092300:" and "Defender:" Then cells(Cells, i, "A").value = (Cells(i, "F").Value) Like "20*"
            ElseIf .value = "51140X:" and "Judiciary:" Then cells(Cells, i, "A").value = (Cells(i, "F").Value) Like "20*"
            ElseIf .value = "51140E:" and "Electronic:" Then cells(Cells, i, "A").value = (Cells(i, "F").Value) Like "20*"
    End if
End With***

'Copies Columns from Budget Availability Reports to SOFC Worksheet
   Sheets("BAR").Columns(1).Copy Destination:=Sheets("SOFC").Columns(4)
   Sheets("BAR").Columns(2).Copy Destination:=Sheets("SOFC").Columns(5)
   Sheets("BAR").Columns(3).Copy Destination:=Sheets("SOFC").Columns(6)
   Sheets("BAR").Columns(4).Copy Destination:=Sheets("SOFC").Columns(7)

'Deletes "Main Worksheet"
   Sheets("BAR").Delete

'Inserts Header Row
   Sheets("SOFC").Range("A2").EntireRow.Insert

'Add Headers to Sheet
   Sheets("SOFC").Range("A1").Value = "BBFY"
   Sheets("SOFC").Range("B1").Value = "EBFY"
   Sheets("SOFC").Range("C1").Value = "FUND"
   Sheets("SOFC").Range("D1").Value = "BUDGET ORG"
   Sheets("SOFC").Range("E1").Value = "BOC"
   Sheets("SOFC").Range("F1").Value = "BOC Name"
   Sheets("SOFC").Range("G1").Value = "ALLOTMENT"

'Deletes Unneeded Rows
   Sheets("SOFC").Activate
  With ActiveSheet
    Firstrow = .UsedRange.Cells(1).Row
    Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
    For Lrow = Lastrow To Firstrow Step -1
        With .Cells(Lrow, "D")
            If Not IsError(.Value) Then
                ElseIf .Value = "Activity Type:" Then .EntireRow.Delete
                ElseIf .Value = "Activity:" Then .EntireRow.Delete
                ElseIf .Value = "AO Division:" Then .EntireRow.Delete
            End If
        End With
    Next Lrow
End With

 'Deletes Rows Based On Criteria
    Last = Cells(Rows.Count, "D").End(xlUp).Row
    For i = Last To 1 Step -1
      If (Cells(i, "D").Value) = "Fund:" Then
         'Cells(i, "A").EntireRow.ClearContents ' USE THIS TO CLEAR CONTENTS BUT NOT DELETE ROW

        ElseIf (Cells(i, "D").Value) = "Activity Type:" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "D").Value) = "Activity:" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "D").Value) = "AO Division:" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "D").Value) = " Org Code" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "F").Value) = "Org Code Subtotal:" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "F").Value) = "AO Division Subtotal:" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "F").Value) = "Activity Subtotal:" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "F").Value) = "Activity Type Subtotal:" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "F").Value) = "Fund Subtotal:" Then
            Cells(i, "A").EntireRow.Delete
'Change Values for Courts in Current Wave
        ElseIf (Cells(i, "F").Value) = "ARW - Arkansas Western" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "F").Value) = "CAN - California Northern" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "F").Value) = "GAS - Georgia Southern" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "F").Value) = "MDX - Maryland" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "F").Value) = "NDX - North Dakota" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "F").Value) = "NYE - New York Eastern" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "F").Value) = "ORX - Oregon" Then
            Cells(i, "A").EntireRow.Delete
        ElseIf (Cells(i, "F").Value) = "SDX - South Dakota" Then
            Cells(i, "A").EntireRow.Delete
'Change Values for Courts in Current Wave
        ElseIf (Cells(i, "F").Value) = "" Then
            Cells(i, "A").EntireRow.Delete
    Else
    End If
Next i

'Gets BBFY and Fund and Place Values in Correct Columns
'Last = Cells(Rows.Count, "D").End(xlUp).Row
   For i = Last To 1 Step -1
     If (Cells(i, "D").Value) = "Fund:" Then
         ElseIf (Cells(i, "F").Value) Like "20*" Then
         YearYo = Left(Cells(i, "20*"), 4)
         If Date Like "20*" Then
         Cells(i, "A").Value = Date
         End If
     Else

    End If
 Next i

'Gets Leading 0 for Fund Code
  Columns("C:C").Select
  Selection.NumberFormat = "000000"


End Sub

Answer 1

一个建议是，如果您的电子表格在BOC栏中保持一致，那么这可能是最好的起点。

Dim i as Integer
Dim j as Integer
Dim LR as Long
LR = Cells(Sheets("NAME").Columns(6).Rows.Count, 1).End(xlUp).Row

For j = 1 to LR
For i = 1 to 3
If Cells(j,i)/Value="" Then
        Cells(j,i).Formula= 'come up with reference for the BOC Name
    Else:
    End If

Next i
Next j

它并不完美，可能可以用For Each做得更好（我对这些并不是很好），但它至少可以开始。此选项无法找到填充空白的动态范围（例如，动态定义大黄色方块并粘贴到其中）。它只是遍历前3行中的所有单元格，直到最后一行的末尾（使用列F（列（6）），因为它似乎是您唯一的完全填充列。）

如果您想更具体地了解每个单元格的内容：

Dim i as Integer
Dim LR as Long
LR = Cells(Sheets("NAME").Columns(6).Rows.Count, 1).End(xlUp).Row

For i = 1 to LR

If Cells(i,1)/Value="" Then
        Cells(i,1).Formula= "=Left(REF,4)'come up with reference for the BOC Name
        Cells(i,2).Formula= "=Left(Right(REF,6),11)
        Cells(i,3).Formula= "=Right(REF,3)
    Else:
    End If

Next i