提取数量

wuliang212

要怎样提取已写在附件中了,在这里要谢谢大家帮忙了

doitbest

Sub arrange()
Dim sht As Worksheet
Dim x As Range
Dim arr(), n&
n = 0
   For Each sht In Sheets(Array("6950-24（橘+蓝）", "6950-28（橘+蓝）"))
     With sht
         For Each x In .Range("c8:c" & .[c8].End(xlDown).Row)
            For Each xx In .Range(.Cells(x.Row, 5), .Cells(x.Row, 256))
                If xx.Row Mod 2 = 0 And xx <> "" Then
                    n = n + 1
                    ReDim Preserve arr(1 To 3, 1 To n)
                    arr(1, n) = Cells(xx.Row, 3).Value
                    arr(2, n) = Cells(7, xx.Column)
                    arr(3, n) = xx.Offset(1, 0)
                    Debug.Print arr(1, n) & arr(2, n) & arr(3, n)
                End If
            Next xx
         Next x
     End With
   Next sht
   Sheets("要求结果").[b2].Resize(n, 3) = Application.Transpose(arr)
End Sub

doitbest

上一附件参考用

wuliang212

所要的结果是对的,但我有很多个表,有时表名要修改,代码要怎样修改.非常感谢

doitbest

Sub arrange()
Dim sht As Worksheet
Dim x As Range
Dim arr(), n&
n = 0
Sheets(1).Select
   For i = 1 To Sheets("sheet1").Index - 1
     With Sheets(i)
         For Each x In .Range("c8:c" & .[c8].End(xlDown).Row)
            For Each xx In .Range(.Cells(x.Row, 5), .Cells(x.Row, 256))
                If xx.Row Mod 2 = 0 And xx <> "" Then
                    n = n + 1
                    ReDim Preserve arr(1 To 3, 1 To n)
                    arr(1, n) = Cells(xx.Row, 3).Value
                    arr(2, n) = Cells(7, xx.Column)
                    arr(3, n) = xx.Offset(1, 0)
                    
                End If
            Next xx
         Next x
     End With
   Next i

   Sheets("sheet1").[b2].Resize(n, 3) = Application.Transpose(arr)
End Sub

wuliang212

谢谢大侠,非常感谢,问题解决了

wuliang212

取数有空格,请大侠帮忙看看,是最后一张表取数不对

wuliang212

单价取数不正确

doitbest

Sub arrange()
Dim sht As Worksheet
Dim x As Range
Dim arr(), n&
n = 0

   For i = 1 To Sheets("sheet1").Index - 1
   Sheets(i).Select
     With Sheets(i)
         For Each x In .Range("c8:c" & .[c8].End(xlDown).Row)
            For Each xx In .Range(.Cells(x.Row, 5), .Cells(x.Row, 256))
                If xx.Row Mod 2 = 0 And xx <> "" Then
                    n = n + 1
                    ReDim Preserve arr(1 To 3, 1 To n)
                    arr(1, n) = Cells(xx.Row, 3).Value
                    arr(2, n) = Cells(7, xx.Column)
                    arr(3, n) = xx.Offset(1, 0)
                    
                End If
            Next xx
         Next x
     End With
   Next i
   Sheets("sheet1").[b2].Resize(n, 3) = Application.Transpose(arr)
End Sub

wuliang212

非常感谢,问题解决了