帮忙改下程序？ - VB6论坛 - 编程论坛档案馆

问题点数：0 回复次数：3

帮忙改下程序？

Sub Macro1()
    Dim wb As Workbook, c As Range, r As Range, rng As Range, lr As Long
    Application.ScreenUpdating = False
    Set rng = Range("F4:I4,N4:O4,Q4:R4,W4:X4")
    Set wb = GetObject(ThisWorkbook.Path & "\Book.xls")
    With wb.Sheets(1)
        lr = .[a65536].End(xlUp).Row - 2
        With .Rows(2)
            For Each r In rng
                Set c = .Find(r.Value, , , 1)
                If Not c Is Nothing Then
                    c.Offset(1).Resize(lr).Copy r.Offset(1)
                End If
            Next
        End With
    End With
    wb.Close False
    Application.ScreenUpdating = True
End Sub

Sub Macro2()
    Dim wb As Workbook, sh As Worksheet, c As Range, r As Range, rng As Range, lr As Long
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    Set rng = Range("F4:I4,N4:O4,Q4:R4,W4:X4")
    Set wb = GetObject(ThisWorkbook.Path & "\Book.xls")
    With wb.Sheets(1)
        lr = .[a65536].End(xlUp).Row - 2
        With .Rows(2)
            For Each r In rng
                Set c = .Find(r.Value, , , 1)
                If Not c Is Nothing Then
                    c.Offset(1).Resize(lr).Copy sh.Cells(65536, r.Column).End(xlUp).Offset(1)
                End If
            Next
        End With
    End With
    wb.Close False
    Application.ScreenUpdating = True
End Sub

Sub Macro3()
    Dim wb As Workbook, sh As Worksheet, c As Range, r As Range, rng As Range, lr As Long, m&
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    Set rng = Range("F4:I4,N4:O4,Q4:R4,W4:X4")
    Set wb = GetObject(ThisWorkbook.Path & "\Book.xls")
    With wb.Sheets(1)
        lr = .[a65536].End(xlUp).Row - 2
        With .Rows(2)
            For Each r In rng
                Set c = .Find(r.Value, , , 1)
                If Not c Is Nothing Then
                    m = sh.Cells(65536, r.Column).End(xlUp).Row + 1
                    If m > 5 Then m = m + 2
                    c.Offset(1).Resize(lr).Copy sh.Cells(m, r.Column)
                End If
            Next
        End With
    End With
    wb.Close False
    Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2016-3-25 15:22编辑过]

第 2 楼

得分:0

Sub Macro4()
    Dim wb As Workbook, sh As Worksheet, c As Range, r As Range, rng As Range, lr As Long
    Dim a, b, d As Object, i&
    Set d = CreateObject("scripting.dictionary")
    a = Array("a", "b")
    b = Array("c", "d")
    For i = 0 To UBound(a)
        d(a(i)) = b(i)
    Next
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    Set rng = Range("F4:X4").SpecialCells(xlCellTypeConstants, 2)
    Set wb = GetObject(ThisWorkbook.Path & "\Book.xls")
    With wb.Sheets(1)
        lr = .[a65536].End(xlUp).Row - 2
        With .Rows(2)
            For Each r In rng
                Set c = .Find(d(r.Value), , , 1)
                If Not c Is Nothing Then
                    c.Offset(1).Resize(lr).Copy sh.Cells(65536, r.Column).End(xlUp).Offset(1)
                End If
            Next
        End With
    End With
    wb.Close False
    Application.ScreenUpdating = True
End Sub

Sub Macro5()
    Dim wb As Workbook, sh As Worksheet, c As Range, r As Range, rng As Range, lr As Long
    Dim a, b, d As Object, i&
    Set d = CreateObject("scripting.dictionary")
    a = Array("a", "b")
    b = Array("c", "d")
    For i = 0 To UBound(a)
        d(a(i)) = b(i)
    Next
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    Set rng = Range("A4:X4")
    rng.Select
    Set wb = GetObject(ThisWorkbook.Path & "\Book.xls")
    With wb.Sheets(1)
        lr = .[a65536].End(xlUp).Row - 2
        With .Rows(2)
            For Each r In rng
                t = d(r.Value)
                If t <> "" Then
                    Set c = .Find(d(r.Value), , , 1)
                    If Not c Is Nothing Then c.Offset(1).Resize(lr).Copy sh.Cells(65536, r.Column).End(xlUp).Offset(1)
                End If
            Next
        End With
    End With
    wb.Close False
    Application.ScreenUpdating = True
End Sub

Sub Macro6()
    Dim wb As Workbook, sh As Worksheet, c As Range, r As Range, rng As Range, lr As Long
    Dim a, b, d As Object, i&
    Set d = CreateObject("scripting.dictionary")
    a = Array("a", "b")
    b = Array("c", "d")
    For i = 0 To UBound(a)
        d(a(i)) = b(i)
    Next
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    Set rng = Range("A4:X4")
    rng.Select
    Set wb = GetObject(ThisWorkbook.Path & "\Book.xls")
    j = sh.UsedRange.Find("*", , -4163, , 1, 2).Row + 1
    With wb.Sheets(1)
        lr = .[a65536].End(xlUp).Row - 2
        With .Rows(2)
            For Each r In rng
                t = d(r.Value)
                If t <> "" Then
                    Set c = .Find(d(r.Value), , , 1)
                    If Not c Is Nothing Then c.Offset(1).Resize(lr).Copy sh.Cells(j, r.Column)
                End If
            Next
        End With
    End With
    wb.Close False
    Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2016-3-25 15:42编辑过]

第 3 楼

得分:0

Sub Macro7()
    Dim wb As Workbook, sh As Worksheet, c As Range, r As Range, rng As Range, lr As Long
    Dim a, b, d As Object, i&
    Set d = CreateObject("scripting.dictionary")
    a = Array("a", "b")
    b = Array("c", "d")
    For i = 0 To UBound(a)
        d(a(i)) = b(i)
    Next
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    Set rng = Range("A4:X4")
    rng.Select
    Set wb = GetObject(ThisWorkbook.Path & "\Book.xls")
    j = sh.UsedRange.Find("*", , -4163, , 1, 2).Row + 1
    With wb.Sheets(1)
        lr = .[a65536].End(xlUp).Row - 2
        With .Rows(2)
            For Each r In rng
                t = d(r.Value)
                If t <> "" Then
                    Set c = .Find(d(r.Value), , , 1)
                    If Not c Is Nothing Then sh.Cells(j, r.Column).Resize(lr).Value = c.Offset(1).Resize(lr).Value
                End If
            Next
        End With
    End With
    wb.Close False
    Application.ScreenUpdating = True
End Sub

Sub Macro8()
    Dim wb As Workbook, sh As Worksheet, c As Range, r As Range, rng As Range, lr As Long
    Dim a, b, d As Object, i&, arr, brr()
    Set d = CreateObject("scripting.dictionary")
    a = Array("a", "b")
    b = Array("c", "d")
    For i = 0 To UBound(a)
        d(a(i)) = b(i)
    Next
    Application.ScreenUpdating = False
    Set sh = ActiveSheet
    Set rng = Range("A4:X4")
    rng.Select
    Set wb = GetObject(ThisWorkbook.Path & "\Book.xls")
    j = sh.UsedRange.Find("*", , -4163, , 1, 2).Row + 1
    With wb.Sheets(1)
        lr = .[a65536].End(xlUp).Row - 2
        ReDim brr(1 To lr * 3, 1 To 1)
        With .Rows(2)
            For Each r In rng
                t = d(r.Value)
                If t <> "" Then
                    Set c = .Find(d(r.Value), , , 1)
                    If Not c Is Nothing Then
                        arr = c.Offset(1).Resize(lr)
                        m = 0
                        For l = 1 To 3
                            For i = 1 To lr
                                m = m + 1
                                brr(m, 1) = arr(i, 1)
                            Next
                        Next
                        sh.Cells(j, r.Column).Resize(m).Value = brr
                    End If
                End If
            Next
        End With
    End With
    wb.Close False
    Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2016-3-25 15:54编辑过]

第 4 楼

得分:0

Sub 更新数据()
    Dim rng As Range
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set rng = Range("b3:b" & Range("b65536").End(xlUp).Row)
    With GetObject(ThisWorkbook.Path & "\B.xls")
        rng.Copy .Sheets(1).[c3]
        Windows("B").Visible = True
        .Close True
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

Sub Macro1()
    Dim arr, i%, lr&, sh As Worksheet
    Application.ScreenUpdating = False
    arr = Array(0, 0, 5, 7, 8, 0, 9, 17)
    Set sh = ActiveSheet
    With GetObject(ThisWorkbook.Path & "\A.xls")
        With .Sheets(1)
            lr = .UsedRange.Row + .UsedRange.Rows.Count - 1
            For i = 2 To UBound(arr)
                If arr(i) Then .Cells(5, arr(i)).Resize(lr).Copy sh.Cells(5, i)
            Next
        End With
        .Close False
    End With
    Application.ScreenUpdating = True
End Sub

  Sub Macro1()
    Dim arr, i%, lr&, sh As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = Array(0, 0, 5, 7, 8, 0, 9, 17)
    Set sh = ActiveSheet
    lr = sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1
    With Workbooks.Open(ThisWorkbook.Path & "\B.xls")
        With .Sheets(1)
            For i = 2 To UBound(arr)
                If arr(i) Then .Cells(5, i).Resize(lr).Value = sh.Cells(5, arr(i)).Resize(lr).Value
            Next
        End With
        .Close True
    End With
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

  Sub Macro1()
    Dim arr, brr(), i%, lr&, sh As Worksheet, c As Range
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = Array(0, 0, 5, 7, 8, 0, 9, 17)
    Set sh = ActiveSheet
    lr = sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1
    ReDim brr(1 To lr, 1 To 1)
    With Workbooks.Open(ThisWorkbook.Path & "\B.xls")
        With .Sheets(1)
            For i = 2 To UBound(arr)
                If arr(i) Then
                    m = 0
                    For Each c In Intersect(sh.Cells(5, arr(i)).Resize(lr), sh.Columns(arr(i)).SpecialCells(12))
                        m = m + 1
                        brr(m, 1) = c.Value
                    Next
                    .Cells(4, i).Resize(m) = brr
                End If
            Next
        End With
        .Close True
    End With
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

[此贴子已经被作者于2016-3-25 16:05编辑过]