求助，根据B列不同日期，得到同等级不同数据的配合比

LMY123

求助，根据B列不同日期，得到同等级不同数据的配合比.rar (24.27 KB, 下载次数: 24)

2012-3-7 20:30 上传

点击文件名下载附件

我想根据B列不同日期，得到同等级不同数据的配合比，如果日期为当年的11月15到次年的3月15日，则VBA的VLOOKUP只引用“配合比”工作表的第2到第4行的数据，其它日期引用“配合比”工作表的第6行到第第8行的数据。

H-002

2012-3-14

101

1区

28天

标准养护

C20

38

27

65

45

19

50

H-008

2012-3-17

101

1区

28天

标准养护

C20

23

15

43

21

13

50

LMY123

不好意思，第第8行打错了，应为第8行，多了一个第

LMY123

代码如下：
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Object
If Target.Count > 2 Then Exit Sub
If Target.Column <> 7 Then Exit Sub
If Target.Row = 1 Then Exit Sub
If Target = "" Then
    Range(Target.Offset(, 1), Target.Offset(, 29)).ClearContents
Else
    Set c = Sheet4.Range("A1:A" & Sheet4.[A65536].End(xlUp).Row).Find(Target, LookIn:=xlValues, LOOKAT:=xlWhole)
    If Not c Is Nothing Then
        Target.Offset(, 1).Resize(, 29) = Sheet4.Range(c.Offset(, 1), c.Offset(, 29)).Value
    Else
        MsgBox "配合比找不到强度: " & Target, vbInformation, "配合比查找"
    End If
End If
Dim a, r As Integer
With ThisWorkbook.Worksheets("台帐")
   B = .Range("B1").End(xlToRight).Column      '1
   r = .[B65536].End(xlUp).Row
   t = Application.WorksheetFunction.Ceiling(.Range("C" & r) / 100, 1)
   If Cells(r, 2) > 40861 And Cells(r, 2) < 40984 Then
      a = t + 4
      Cells(r, 1).Offset(1, 0).Resize(a, B) = Cells(r, 1).Offset(0, 0).Resize(1, B).Value     '2
      For i = 1 To a
         .Range("A" & r + i) = "H-" & Format(i + r - 1, "000")
      Next i
   Else
      a = t
      Cells(r, 1).Offset(1, 0).Resize(a, B) = Cells(r, 1).Offset(0, 0).Resize(1, B).Value       '3
      For i = 1 To a
         .Range("A" & r + i) = "H-" & Format(i + r - 1, "000")
      Next i
   End If
End With
If Cells(r, 2) > 40861 And Cells(r, 2) < 40984 Then
   Cells(r + a, 6) = "同条件养护"
   Cells(r + a - 1, 6) = "同条件养护"
   Cells(r + a - 2, 6) = "同条件养护"
   Cells(r + a - 3, 6) = "同条件养护"
   Cells(r + a - 4, 6) = "同条件养护转标准养护"
   Range("A" & r + a).Value = Replace(Range("A" & r + a), "H", "HST")
   Range("A" & r + a - 1).Value = Replace(Range("A" & r + a - 1), "H", "HG")
   Range("A" & r + a - 2).Value = Replace(Range("A" & r + a - 2), "H", "HM")
   Range("A" & r + a - 3).Value = Replace(Range("A" & r + a - 3), "H", "HN")
   Range("A" & r + a - 4).Value = Replace(Range("A" & r + a - 4), "H", "HTZB")
   Cells(r + a, 5) = "结构实体"
   Cells(r + a - 1, 5) = "14天"
   Cells(r + a - 2, 5) = "7天"
   Cells(r + a - 3, 5) = "3天"
   Cells(r + a - 4, 5) = "28天转28天"
Else
   Cells(r + a, 6) = "同条件养护"
   Cells(r + a, 5) = "结构实体"
   Range("A" & r + a).Value = Replace(Range("A" & r + a), "H", "HST")
End If
If Target.Column = 7 Then
    If Target.Value <> "" Then
        Application.ScreenUpdating = False
        Sheets("样表").Select
        For i = 0 To a     '1
            Sheets("样表").Copy Before:=Sheets(1)
            ActiveSheet.Name = Target.Offset(i, -6).Value
            Sheets(Target.Offset(i, -6).Value).Move After:=Sheets(Sheets.Count)
            Sheets(Target.Offset(i, -6).Value).Tab.ColorIndex = 3
            Sheets(Target.Offset(i, -6).Value).Cells(9, 7) = Target.Offset(i, -6).Value
        Next
        Sheets("台帐").Select
        Application.ScreenUpdating = True
    End If
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Row = 1 Or Target.Column <> 1 Or Target = "" Then Exit Sub
Sheets(Target.Value).Select
End Sub

LMY123

这些代码都是网上的朋友帮忙写的，我再次向他们表示感谢，也恳请你伸出援助之手，给我指点一下，先行谢过。

LMY123

同等级就是同强度的意思

LMY123

请各位有空帮我看一看代码怎么写，谢谢你们

mjzxlmg

LMY123 发表于 2012-3-7 21:34
请各位有空帮我看一看代码怎么写，谢谢你们

你上面不是有代码了吗？
不过上面的代码也太复杂了吧。

LMY123

谢谢你的关注

LMY123

求助，用change事件提取数据.rar (4.51 KB, 下载次数: 24)

2012-3-8 09:47 上传

点击文件名下载附件

这个和我的问题差不多

ww2957

问题深奥，只能帮您顶了。