[已解决]字符提取排列

hanjia · 发表于 2013-9-12 18:40

本帖最后由 hanjia 于 2013-9-12 19:40 编辑

提取A列字符如A1是大自动排在C1  像A2是小就自动跳到D1
A3是小自动排在D列 A4换大就自动跳到E1
像A2是小就自动跳到D1
最好是判断后在Sheet2排列

A       B    C       D    E       F       G
大
小       大    小    大    小    大    小
小                小    大    小    大    小
大                                           大    小
大                                           大
小
小
大
大
大
大
小
小
小

Book1.rar (6.69 KB, 下载次数: 2)

zjdh · 发表于 2013-9-12 19:14

如果第一个字符为“小”怎么办？
如果6列之后又出现“大”怎么办？

sgxb123431380 · 发表于 2013-9-12 19:16

Private Sub cx
x = 1
y = 1
i = 2
Sheet2.Cells(x, y) = ActiveSheet.Cells(1, 1)
Do While ActiveSheet.Cells(i, 1) <> ""
      If ActiveSheet.Cells(i, 1) = ActiveSheet.Cells(i - 1, 1) Then
         x = x + 1
         Sheet2.Cells(x, y) = ActiveSheet.Cells(i, 1)
      Else
         y = y + 1
         x = 1
         Sheet2.Cells(x, y) = ActiveSheet.Cells(i, 1)
      End If
      i = i + 1
Loop

Sheet2.Activate

End Sub

hanjia · 发表于 2013-9-12 19:23

zjdh 发表于 2013-9-12 19:14
如果第一个字符为“小”怎么办？
如果6列之后又出现“大”怎么办？

返正第一个就是放在第一位再来就接着往后排

zjdh · 发表于 2013-9-12 19:31

本帖最后由 zjdh 于 2013-9-12 19:38 编辑

Sub TEST()
D = 1
ARR = Range("A1:A" & Range("A65536").End(3).Row)
ReDim T(1 To 1)
T(D) = ARR(1, 1)
Z = ARR(1, 1)
For I = 2 To UBound(ARR)
      If ARR(I, 1) = Z Then
         T(D) = T(D) & Chr(10) & ARR(I, 1)
      Else
         D = D + 1
         ReDim Preserve T(1 To D)
         T(D) = ARR(I, 1)
         Z = ARR(I, 1)
      End If
Next
Sheets(2).Range("A1").Resize(1, UBound(T)) = T
End Sub

Book1.rar (12.88 KB, 下载次数: 6)

hanjia · 发表于 2013-9-12 19:48

zjdh 发表于 2013-9-12 19:31
Sub TEST()
D = 1
ARR = Range("A1:A" & Range("A65536").End(3).Row)

你好能不能再提取一排？比如提取B列到Shee2第五行

hanjia · 发表于 2013-9-12 20:46

本帖最后由 hanjia 于 2013-9-12 20:49 编辑

zjdh 发表于 2013-9-12 19:31
Sub TEST()
D = 1
ARR = Range("A1:A" & Range("A65536").End(3).Row)

如何再增加提取B列
还有就是大  双字要红色的  其他字体为黑色
Sub TEST()
   D = 1
   ARR = Range("A1:A" & Range("A65536").End(3).Row)
   ReDim T(1 To 1)
   T(D) = ARR(1, 1)
   Z = ARR(1, 1)
   For I = 2 To UBound(ARR)
      If ARR(I, 1) = Z Then
         T(D) = T(D) & Chr(10) & ARR(I, 1)
      Else
         D = D + 1
         ReDim Preserve T(1 To D)
         T(D) = ARR(I, 1)
         Z = ARR(I, 1)
      End If
   Next
   Sheets(2).Range("A1").Resize(1, UBound(T)) = T
End Sub

Book1.rar (12.81 KB, 下载次数: 1)

zjdh · 发表于 2013-9-12 21:51

你就再提取一次吧。
Sub TEST()
D = 1
ARR = Range("A1:A" & Range("A65536").End(3).Row)
ReDim T(1 To 1)
T(D) = ARR(1, 1)
Z = ARR(1, 1)
For I = 2 To UBound(ARR)
      If ARR(I, 1) = Z Then
         T(D) = T(D) & Chr(10) & ARR(I, 1)
      Else
         D = D + 1
         ReDim Preserve T(1 To D)
         T(D) = ARR(I, 1)
         Z = ARR(I, 1)
      End If
Next
Sheets(2).Range("A1").Resize(1, UBound(T)) = T
D = 1
ARR = Range("B1:B" & Range("B65536").End(3).Row)
ReDim T(1 To 1)
T(D) = ARR(1, 1)
Z = ARR(1, 1)
For I = 2 To UBound(ARR)
      If ARR(I, 1) = Z Then
         T(D) = T(D) & Chr(10) & ARR(I, 1)
      Else
         D = D + 1
         ReDim Preserve T(1 To D)
         T(D) = ARR(I, 1)
         Z = ARR(I, 1)
      End If
Next
Sheets(2).Range("A5").Resize(1, UBound(T)) = T
End Sub

hanjia · 发表于 2013-9-12 22:06

zjdh 发表于 2013-9-12 21:51
你就再提取一次吧。
Sub TEST()
D = 1

我是再提了一次但是提到sheet2第5行的时候他是左右排了有是像1行那样上下排啊
QQ图片20130912220214.jpg

还得改那才能像1行那么显示？

hanjia · 发表于 2013-9-12 22:09

zjdh 发表于 2013-9-12 21:51
你就再提取一次吧。
Sub TEST()
D = 1

我把付件传上来拜托你再帮我改一下谢谢

Book1.rar (12.81 KB, 下载次数: 1)

		自动登录	找回密码
密码			注册