返回列表 上一主題 發帖

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

amu1129

帖子
27 
主題
12 
精華
0 
積分
318 
點名
281  
作業系統
Windows 
軟體版本
7 
閱讀權限
20 
性別
男 
註冊時間
2010-7-20 
最後登錄
2024-11-17 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2010-8-15 14:11 | 只看該作者

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

請問我有一個表格如下面第一張圖
我想在輸入完sheet1的表格後
在sheet2跑出sheet1有值的資訊如第二張圖
是不是得用VBA寫才行?
而且還要有字體顏色，應該不能用函數直接寫吧?
煩請各位大大指點


Form.rar (2.32 KB)
收藏 分享
50 字節以內
不支持自定義 Discuz! 代碼

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-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

amu1129

帖子
27 
主題
12 
精華
0 
積分
318 
點名
281  
作業系統
Windows 
軟體版本
7 
閱讀權限
20 
性別
男 
註冊時間
2010-7-20 
最後登錄
2024-11-17 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章
3#
發表於 2010-8-16 22:57 | 只看該作者
回復 2# GBKEE
跑出來了 謝謝版主
但我想再稍作修改 像下圖

我土法煉鋼改成以下這樣
但是好像不對
我還想請問向中間沒數值的話
會有空白列 可以不要有空白嗎
如果要修改字型的話 要放在迴圈內還是迴圈外
煩請版主為小弟解惑一下

Sub Ex()
    Dim Ar(), E As Range, Msg$, i%, y%, C%
    Ar = Array("a2", "g2", "a8", "g8")
    C = 4
    For i = 1 To Sheet1.[C2:F6].Columns.Count
        Msg = ""
        y = 0
        For Each E In [C2:F6].Columns(i).Cells
            If E <> "" Then
                Msg = IIf(Msg <> "", Msg & Chr(10), "") & "在" & Cells(E.Row, 1) & "店買了" & Cells(E.Row, 2) & E & "枝"

                y = y + 1
            End If
        Next
        Sheet2.Range(Ar(i - 1)) = IIf(Msg <> "", Msg & Application.Rept(Chr(10), IIf(y < C, C - y, 0)) & IIf(y < C, "請至A店取貨", ""), "")
    Next
    For i = 1 To Sheet1.[C7:F11].Columns.Count
        Msg = ""
        y = 0
        For Each E In [C7:F11].Columns(i).Cells
            If E <> "" Then
                Msg = IIf(Msg <> "", Msg & Chr(10), "") & "在" & Cells(E.Row, 1) & "店買了" & Cells(E.Row, 2) & E & "枝"

                y = y + 1
            End If
        Next
        Sheet2.Range(Ar(i - 1)) = IIf(Msg <> "", Msg & Application.Rept(Chr(10), IIf(y < C, C - y, 0)) & IIf(y < C, "請至B店取貨", ""), "")
    Next
End Sub
50 字節以內
不支持自定義 Discuz! 代碼

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 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

amu1129

帖子
27 
主題
12 
精華
0 
積分
318 
點名
281  
作業系統
Windows 
軟體版本
7 
閱讀權限
20 
性別
男 
註冊時間
2010-7-20 
最後登錄
2024-11-17 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章
5#
發表於 2010-8-18 18:06 | 只看該作者
回復 4# GBKEE

不好意思~版主
我怎麼改一下格式就跑不出來了
我想讓圖一變成圖二那樣
另外再加一個按鈕在下面讓此巨集自動動作(圖三紅色處)
麻煩版主大人了



Test.rar (10.16 KB)
50 字節以內
不支持自定義 Discuz! 代碼

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 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

        靜思自在 : 有願放在心裡，沒有身體力行，正如耕田不播種，皆是空過因緣。
返回列表 上一主題