返回列表 上一主題 發帖

請問如何將表格的資訊整理成我要的資訊

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2010-8-15 16:17 | 顯示全部帖子
回復 1# amu1129
  1. Sub Ex()
  2.     Dim Ar(), E As Range, Msg$, i%, y%, C%
  3.     Ar = Array("a2", "g2", "a8", "g8")
  4.     C = 4
  5.     For i = 1 To Sheet1.[C2:F11].Columns.Count
  6.         Msg = ""
  7.         y = 0
  8.         For Each E In [C2:F11].Columns(i).Cells
  9.             If E <> "" Then
  10.                 Msg = IIf(Msg <> "", Msg & Chr(10), "") & "在" & Cells(E.Row, 1) & "店買了" & Cells(E.Row, 2) & E & "枝"
  11.                 y = y + 1
  12.             End If
  13.         Next
  14.         Sheet2.Range(Ar(i - 1)) = IIf(Msg <> "", Msg & Application.Rept(Chr(10), IIf(y < C, C - y, 0)) & IIf(y < C, "以上", ""), "")
  15.     Next
  16. End Sub
複製代碼

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2010-8-17 11:31 | 顯示全部帖子
回復 3# amu1129
  1. Sub Ex()
  2.     Dim Ar(), E, Msg$, i%, y%, C%, MsgAr
  3.     Ar = Array("a2", "g2", "a8", "g8")
  4.     C = 4
  5.     With Sheet1
  6.         For i = 1 To .[C2:F11].Columns.Count
  7.             Msg = ""
  8.             y = 0
  9.             For Each E In .[C2:F11].Columns(i).Cells
  10.                 If E <> "" Then
  11.                     Msg = IIf(Msg <> "", Msg & Chr(10), "") & "在" & .Cells(E.Row, 1) & "店買了" & .Cells(E.Row, 2) & E & "枝"
  12.                     y = y + 1
  13.                 End If
  14.             Next
  15.             Sheet2.Range(Ar(i - 1)) = Msg
  16.         Next
  17.     End With
  18.     With Sheet2
  19.         For Each E In Ar      ''''' 加入文字
  20.             MsgAr = Split(.Range(E), Chr(10))
  21.             If UBound(MsgAr) >= 1 Then
  22.                 For i = 0 To UBound(MsgAr)
  23.                     If i < UBound(MsgAr) Then
  24.                         y = InStr(MsgAr(i), "店")
  25.                         If Mid(MsgAr(i), 1, y) <> Mid(MsgAr(i + 1), 1, y) Then
  26.                             MsgAr(i) = MsgAr(i) & Chr(10) & "請至" & Mid(MsgAr(i), 2, y - 1) & "取貨"
  27.                         End If
  28.                     End If
  29.                 Next
  30.             End If
  31.             If UBound(MsgAr) > -1 Then
  32.                 y = InStr(MsgAr(UBound(MsgAr)), "店")
  33.                 MsgAr(UBound(MsgAr)) = MsgAr(UBound(MsgAr)) & Chr(10) & "請至" & Mid(MsgAr(UBound(MsgAr)), 2, y - 1) & "取貨" & Chr(10) & "以上"
  34.                 .Range(E) = Join(MsgAr, Chr(10))
  35.             End If
  36.         Next
  37.         For Each E In Ar        ''''' 處理顏色
  38.             MsgAr = Split(.Range(E), Chr(10))
  39.             .Range(E).Font.ColorIndex = 3
  40.             C = 1
  41.             For i = 0 To UBound(MsgAr)
  42.                 If InStr(MsgAr(i), "在") > 0 Then
  43.                     y = InStr(MsgAr(i), "店")
  44.                 Else
  45.                     y = 0
  46.                 End If
  47.                 If y > 0 Then .Range(E).Characters(Start:=C, Length:=y).Font.ColorIndex = 10
  48.                 C = C + Len(MsgAr(i)) + 1
  49.             Next
  50.         Next
  51.     End With
  52. End Sub
複製代碼

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 2010-8-19 08:57 | 顯示全部帖子
回復 5# amu1129
  1. With Sheet2
  2.         For Each E In Ar      ''''' 加入文字
  3.             MsgAr = Split(.Range(E), Chr(10))
  4.             If UBound(MsgAr) >= 1 Then
  5.                 For i = 0 To UBound(MsgAr)
  6.                     If i < UBound(MsgAr) Then
  7.                         y = InStr(MsgAr(i), "至")
  8.                         yy = InStr(MsgAr(i + 1), "至")
  9.                         If Mid(MsgAr(i), y, 8) <> Mid(MsgAr(i + 1), yy, 8) Then
  10.                             yy = InStr(MsgAr(i), "(小包裝)")
  11.                              Store = Mid(MsgAr(i), y + 1, yy - y - 2)
  12.                             MsgAr(i) = MsgAr(i) & Chr(10) & "請至" & Store & "取貨(分機:123 連絡)"
  13.                         End If
  14.                     End If
  15.                 Next
  16.             End If
  17.             If UBound(MsgAr) > -1 Then
  18.                 i = UBound(MsgAr)
  19.                 y = InStr(MsgAr(i), "至")
  20.                 yy = InStr(MsgAr(i), "(小包裝)")
  21.                 Store = Mid(MsgAr(i), y + 1, yy - y - 2)
  22.                 MsgAr(i) = MsgAr(i) & Chr(10) & "請至" & Store & "取貨(分機:223 連絡)" & Chr(10) & Chr(10) & "請速至領取" & Chr(10) & "**請於領取後告知"
  23.                 .Range(E) = Join(MsgAr, Chr(10))
  24.             End If
  25.         Next
  26.         For Each E In Ar        ''''' 處理顏色
  27.             MsgAr = Split(.Range(E), Chr(10))
  28.             .Range(E).Font.ColorIndex = 3
  29.             C = 1
  30.             For i = 0 To UBound(MsgAr)
  31.                 y = InStr(MsgAr(i), "送至")
  32.                 If y > 0 Then .Range(E).Characters(Start:=C, Length:=y + 1).Font.ColorIndex = 10
  33.                 If InStr(MsgAr(i), "分機") > 0 Then .Range(E).Characters(Start:=C, Length:=Len(MsgAr(i))).Font.ColorIndex = 9
  34.                 C = C + Len(MsgAr(i)) + 1
  35.             Next
  36.         Next
  37.     End With
複製代碼

TOP

        靜思自在 : 犯錯出懺悔心，才能清淨無煩惱。
返回列表 上一主題