返回列表 上一主題 發帖

請問前輩一個好難的VBA報表設計

tsou516

帖子
6 
主題
2 
精華
0 
積分
8 
點名
0  
作業系統
Windows 
軟體版本
Office 2010 
閱讀權限
10 
性別
男 
註冊時間
2013-10-15 
最後登錄
2015-9-23 

論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2014-1-17 17:36 | 只看該作者

請問前輩一個好難的VBA報表設計

各位前輩，小弟為了工作需求，買了VBA的書，寫了一個爛的VBA去執行，產生需要的報表
但有太多的問題小弟沒辦法短時間突破，但老闆又要的非常急為了小弟的飯碗，小弟不得不
來和各位前軰求救，請各位前輩幫忙，跪謝！拜託拜託。

VBA.rar (24.31 KB)
收藏 分享

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2014-1-17 20:41 | 只看該作者
回復 1# tsou516
將Sheet1.B01~B15的值放入規定的Sheet2.L欄~T欄的位置(有的要相加)
B01~B15有15欄 ,L欄~T欄有9欄,這欄數不對等,
你需說明 D-Pak,SO-8,PMPAK,SPR-PAK ,SOT-23,SOT-26,TO-220,TO-263 的條件
  1. Sub 迴圈()
  2.     Dim Rng As Range, M As Variant, E
  3.     Set Rng = Sheets("SHEET3").Range("A:A")
  4.     Sheets("SHEET2").UsedRange.Offset(1).Clear
  5.     For Each E In Sheets("SHEET1").Range("A:A").SpecialCells(xlCellTypeConstants) '特殊儲存格(字串),排除空白儲存格.
  6.         If E.Row > 1 Then        '排除表頭
  7.             M = Application.Match(E, Rng, 0)  '搜尋Device在Rng的位置=列號
  8.             If IsNumeric(M) Then              '是數字:有找到Device在Rng的位置
  9.                 With Sheets("SHEET2").Cells(Sheets("SHEET2").Rows.Count, "A").End(xlUp).Offset(1) 'SHEET2 A欄 寫上的位置
  10.                      'SHEET2 A欄 由下往上到有資料儲存格的下一列
  11.                     .Range("A1") = Rng.Cells(M, 2)   'Package 在 Device 的右欄
  12.                     .Range("B1") = E                 'Device
  13.                     .Range("D1") = E.Range("C1")     'Datecode
  14.                     .Range("E1") = E.Range("D1")     'Wafer ID
  15.                     '*************************
  16.                     '等候你的條件說明後寫程式碼
  17.                     '*************************
  18.                 End With
  19.             End If
  20.         End If
  21.     Next
  22. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

tsou516

帖子
6 
主題
2 
精華
0 
積分
8 
點名
0  
作業系統
Windows 
軟體版本
Office 2010 
閱讀權限
10 
性別
男 
註冊時間
2013-10-15 
最後登錄
2015-9-23 

論壇贊助勳章
3#
發表於 2014-1-18 03:13 | 只看該作者
感謝前輩願意出手相救，萬分感謝，我再補上需求和條件的說明，再請您過目！

設計說明.rar (13.72 KB)

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#
發表於 2014-1-18 15:59 | 只看該作者
回復 3# tsou516
  1. Sub 迴圈()
  2.     Dim Rng(1 To 6) As Range, E As Variant, M As Variant, M1 As Variant, i As Integer, ii As Integer
  3.     With Sheets("sheet1")                                  '客戶資料
  4.         If .[COUNTA(A:A)] <> .UsedRange.Rows.Count Then .Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete '刪除空白列
  5.         For E = 0 To 14
  6.             .[E1].Offset(, E).Name = .[E1].Offset(, E) & "值" '定義名稱:  B01 B02 B03 B04.....
  7.         Next
  8.     End With
  9.     Sheets("Sheet2").UsedRange.Offset(1).Clear              '清除第二列(含)後的資料
  10.     Set Rng(1) = Sheets("Sheet1").UsedRange.Columns(1)      '客戶資料
  11.     Set Rng(2) = Sheets("Sheet2").Range("A:A")              '要寫入的範圍
  12.     Set Rng(3) = Sheets("Sheet3").Range("A:A")              'Device
  13.     Set Rng(4) = Sheets("Sheet4").Range("A:A")              'Package
  14.     Set Rng(5) = Sheets("Sheet4").Range("B1:N1")            'Test out Q'ty,RG/SWT ....
  15.     For Each E In Rng(1).Cells                              '客戶資料
  16.         If E.Row > 1 Then                                   '排除表頭
  17.             M = Application.Match(E, Rng(3), 0)             '搜尋Sheet1的Device在Sheet3的列位
  18.             If IsNumeric(M) Then M1 = Application.Match(Rng(3).Cells(M, 2), Rng(4), 0)
  19.                                                             'M1: 傳回Sheet3的Package在Sheet4的列位
  20.             If IsNumeric(M) And IsNumeric(M1) Then
  21.                 i = Application.CountA(Rng(2)) + 1          '計算有文字儲存格數
  22.                 With Sheets("SHEET2").Cells(i, "A")         'SHEET2 A欄 寫上的位置
  23.                     .Range("A1") = Rng(4).Cells(M1, 1)      'Sheet4對應的Package
  24.                     .Range("B1") = E                        'Device
  25.                     .Range("D1") = E.Range("C1")            'Datecode
  26.                     .Range("E1") = E.Range("D1")            'Wafer ID
  27.                     For Each C In Rng(5).Offset(M1 - 1)     '比對對應的'B01 B02 B03 B04.....
  28.                         If C <> "" Then
  29.                             M = Application.Match(C.Parent.Cells(1, C.Column), Rng(2).Cells(1).EntireRow, 0)   '搜尋Sheets("Sheet2")的欄位
  30.                             'M=B01 B02 B03 B04.....上方第一列標頭在Sheet2第一列的欄位數
  31.                             For ii = 0 To UBound(Split(C, "+")) '字串以"+"分割成陣列
  32.                                 '.Parent.Cells(i, M) = .Parent.Cells(i, M) + Range(Split(C, "+")(ii)).Offset(E.Row - 1)           'SHEET4的格式 B01值 B02值 B03值 B04值.....
  33.                                 .Parent.Cells(i, M) = .Parent.Cells(i, M) + Range(Split(C, "+")(ii) & "值").Offset(E.Row - 1)   'SHEET4的格式 B01 B02 B03 B04.....
  34.                                 '.Parent -> Sheets("SHEET2")
  35.                                 'Range(Split(C, "+")(ii) & "值"): 工作表上所定義名稱的位置
  36.                             Next
  37.                         End If
  38.                     Next
  39.                 End With
  40.            Else
  41.                 If Rng(6) Is Nothing Then
  42.                     Set Rng(6) = E.EntireRow                    '比對不到的Device,Package
  43.                 Else
  44.                     Set Rng(6) = Union(Rng(6), E.EntireRow)     'Union 方法  傳回兩個或多個範圍的合併範圍。

  46.                 End If
  47.            End If
  48.         End If
  49.     Next
  50.     If Not Rng(6) Is Nothing Then Rng(6).Delete
  51. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

tsou516

帖子
6 
主題
2 
精華
0 
積分
8 
點名
0  
作業系統
Windows 
軟體版本
Office 2010 
閱讀權限
10 
性別
男 
註冊時間
2013-10-15 
最後登錄
2015-9-23 

論壇贊助勳章
5#
發表於 2014-2-6 16:48 | 只看該作者
回復 4# GBKEE

非常感謝GBKEE版大的幫忙，讓我的工作能暫時保住，謝謝！

TOP

        靜思自在 : 待人退一步，愛人寬一寸，就會活得很快樂。
返回列表 上一主題