返回列表 上一主題 發帖

[發問] 如何將表單1+表單2 合併

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
61  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-3-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2012-3-16 21:37 | 顯示全部帖子
回復 6# owen9399
  1. Sub All_Paper() '全部年報
  2. Dim Sh As Worksheet, A As Range, C As Range, Ay()
  3. For Each Sh In Sheets(Array("小型股", "大型股"))
  4.    With Sh
  5.      Set A = .[A:A].Find("公司序號", .[A65536], lookat:=xlWhole)
  6.      Do Until Application.CountA(A.Offset(, 1).Resize(, 12)) = 0
  7.         r = A.Row
  8.         r1 = .Range("A:A").Find("合計", A, lookat:=xlWhole).Row
  9.         r2 = .Range("A:A").FindNext(.Cells(r1, 1)).Row
  10.         For Each C In A.Offset(, 1).Resize(, 12).SpecialCells(xlCellTypeConstants)
  11.         k = C.Column
  12.         ReDim Preserve Ay(s)
  13.         Ay(s) = Array(.Cells(r, k).Value, .Cells(r + 1, k).Value, .Cells(r1 + 1, k - 1).Value, .Cells(r1, k).Value, .Cells(r1 + 1, k + 1).Value, .Cells(r2, k).Value, .Cells(r2 + 1, k).Value)
  14.         s = s + 1
  15.         Next
  16.      Set A = .Range("A:A").Find("公司序號", .Cells(r2, 1), lookat:=xlWhole)
  17.      Loop
  18.    End With
  19. Next
  20. If s > 0 Then
  21. With Sheets("全部公司總年報")
  22. .[A2].Resize(s, 7) = Application.Transpose(Application.Transpose(Ay))
  23. .Range("A1").CurrentRegion.Sort key1:=.[A1], Header:=xlYes
  24. End With
  25. End If
  26. End Sub
  27. Sub S_Paper() '小型股年報
  28. Dim A As Range, C As Range, Ay()
  29.    With Sheets("小型股")
  30.      Set A = .[A:A].Find("公司序號", .[A65536], lookat:=xlWhole)
  31.      Do Until Application.CountA(A.Offset(, 1).Resize(, 12)) = 0
  32.         r = A.Row
  33.         r1 = .Range("A:A").Find("合計", A, lookat:=xlWhole).Row
  34.         r2 = .Range("A:A").FindNext(.Cells(r1, 1)).Row
  35.         For Each C In A.Offset(, 1).Resize(, 12).SpecialCells(xlCellTypeConstants)
  36.         k = C.Column
  37.         ReDim Preserve Ay(s)
  38.         Ay(s) = Array(.Cells(r, k).Text, .Cells(r + 1, k).Value, .Cells(r1 + 1, k - 1).Value, .Cells(r1, k).Value, .Cells(r1 + 1, k + 1).Value, .Cells(r2, k).Value, .Cells(r2 + 1, k).Value)
  39.         s = s + 1
  40.         Next
  41.      Set A = .Range("A:A").Find("公司序號", .Cells(r2, 1), lookat:=xlWhole)
  42.      Loop
  43.    End With
  44. If s > 0 Then
  45. With Sheets("小型股年報")
  46. .[A2].Resize(s, 7) = Application.Transpose(Application.Transpose(Ay))
  47. .Range("A1").CurrentRegion.Sort key1:=.[A1], Header:=xlYes
  48. End With
  49. End If
  50. End Sub
  51. Sub U_Paper() '大型股年報
  52. Dim A As Range, C As Range, Ay()
  53.    With Sheets("大型股")
  54.      Set A = .[A:A].Find("公司序號", .[A65536], lookat:=xlWhole)
  55.      Do Until Application.CountA(A.Offset(, 1).Resize(, 12)) = 0
  56.         r = A.Row
  57.         r1 = .Range("A:A").Find("合計", A, lookat:=xlWhole).Row
  58.         r2 = .Range("A:A").FindNext(.Cells(r1, 1)).Row
  59.         For Each C In A.Offset(, 1).Resize(, 12).SpecialCells(xlCellTypeConstants)
  60.         k = C.Column
  61.         ReDim Preserve Ay(s)
  62.         Ay(s) = Array(.Cells(r, k).Text, .Cells(r + 1, k).Value, .Cells(r1 + 1, k - 1).Value, .Cells(r1, k).Value, .Cells(r1 + 1, k + 1).Value, .Cells(r2, k).Value, .Cells(r2 + 1, k).Value)
  63.         s = s + 1
  64.         Next
  65.      Set A = .Range("A:A").Find("公司序號", .Cells(r2, 1), lookat:=xlWhole)
  66.      Loop
  67.    End With
  68. If s > 0 Then
  69. With Sheets("大型股年報")
  70. .[A2].Resize(s, 7) = Application.Transpose(Application.Transpose(Ay))
  71. .Range("A1").CurrentRegion.Sort key1:=.[A1], Header:=xlYes
  72. End With
  73. End If
  74. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
61  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-3-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2012-3-17 19:03 | 顯示全部帖子
回復 9# owen9399
  1. Sub 全部公司總年報_按鈕1_Click()
  2. Dim Sh As Worksheet, A As Range, C As Range, Ay()
  3. For Each Sh In Sheets(Array("小型股", "大型股"))
  4.    With Sh
  5.      Set A = .[A:A].Find("公司序號", .[A65536], lookat:=xlWhole)
  6.      Do Until Application.CountA(A.Offset(, 1).Resize(, 12)) = 0
  7.           r = A.Row   
  8.         r1 = .Range("A:A").Find("合計", A, lookat:=xlWhole).Row
  9.         r2 = .Range("A:A").FindNext(.Cells(r1, 1)).Row
  10.         For Each C In A.Offset(, 1).Resize(, 12).SpecialCells(xlCellTypeConstants)
  11.         k = C.Column
  12.         ReDim Preserve Ay(s)
  13.         Ay(s) = Array(.Cells(r, k).Value, .Cells(r + 1, k).Value, .Cells(r1 + 1, k - 1).Value, .Cells(r1, k).Value, .Cells(r1 + 1, k + 1).Value, .Cells(r2, k).Value, "=rc6-rc5-rc10+rc11", "=if(rc5-rc6-rc10>0,0,rc6-rc5-rc10)", "=if(rc5-rc6-rc11<0,0,rc5-rc6-rc11)")
  14.         s = s + 1
  15.         Next
  16.      Set A = .Range("A:A").Find("公司序號", .Cells(r2, 1), lookat:=xlWhole)
  17.      Loop
  18.    End With
  19. Next
  20. If s > 0 Then
  21. With Sheets("全部公司總年報")
  22. .[A2].Resize(s, 9) = Application.Transpose(Application.Transpose(Ay))
  23. .Range("A1").CurrentRegion.Sort key1:=.[A1], Header:=xlYes
  24. r = 42: k = 0
  25. Do Until .Cells(r, 1) = ""
  26. .Cells(r, 1).EntireRow.Insert
  27. .[A1:I1].Copy .Cells(r, 1)
  28. k = k + 1
  29. r = r + 40 + k
  30. Loop
  31. End With
  32. End If
  33. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
61  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-3-12 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 2012-3-19 18:55 | 顯示全部帖子
回復 12# owen9399
  1. Sub 全部公司總年報_按鈕1_Click()


  4. Dim Sh As Worksheet, A As Range, C As Range, Ay()

  6. For Each Sh In Sheets(Array("小型股", "大型股"))

  8.    With Sh

  10.      Set A = .[A:A].Find("公司序號", .[A65536], lookat:=xlWhole)

  12.      Do Until Application.CountA(A.Offset(, 1).Resize(, 12)) = 0

  14.          r = A.Row

  16.         r1 = .Range("A:A").Find("合計", A, lookat:=xlWhole).Row

  18.         r2 = .Range("A:A").FindNext(.Cells(r1, 1)).Row

  20.        For Each C In A.Offset(, 1).Resize(, 12).SpecialCells(xlCellTypeConstants)

  22.         k = C.Column

  24.         ReDim Preserve Ay(s)

  26.        Ay(s) = Array(.Cells(r, k).Value, .Cells(r + 1, k).Value, .Cells(r1 + 1, k - 1).Value, .Cells(r1, k).Value, .Cells(r1 + 1, k + 1).Value, .Cells(r2, k).Value, "=rc6-rc5-rc10+rc11", "=if(rc5-rc6-rc10>0,0,rc6-rc5-rc10)", "=if(rc5-rc6-rc11<0,0,rc5-rc6-rc11)")

  28.         s = s + 1

  30.         Next

  32.         Set A = .Range("A:A").Find("公司序號", .Cells(r2, 1), lookat:=xlWhole)
  33.         
  34.      Loop

  36.    End With

  38. Next

  40. If s > 0 Then

  42. With Sheets("全部公司總年報")
  43. .UsedRange.Offset(1).Clear

  45. .[A2].Resize(s, 9) = Application.Transpose(Application.Transpose(Ay))

  47. .Range("A1").CurrentRegion.Sort key1:=.[A1], Header:=xlYes

  49. r = 42: k = 0

  51. Do Until .Cells(r, 1) = ""

  53. .Cells(r, 1).EntireRow.Insert

  55. .[A1:L1].Copy .Cells(r, 1)

  57. k = k + 1

  59. r = r + 40 + k

  61. Loop

  63. End With

  65. End If



  69. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 【停滯不前，終無所得】人都迷於尋找奇蹟，因而停滯不前；縱使時間再多、路再長，也了無用處，終無所得。
返回列表 上一主題