Board logo

標題: 列増減 [打印本頁]
作者: y663258    時間: 2010-5-18 20:31     標題: 列増減

報表列數可否依來源資料増減，謝謝協助。[attach]677[/attach][attach]677[/attach]
作者: Min    時間: 2010-5-18 20:45

參考一下這篇文章...
http://forum.twbts.com/viewthread.php?tid=251&extra=page%3D1
作者: y663258    時間: 2010-5-19 10:11

謝謝MIN版主
                      上去看了文章還是一知半解，無法自己解決問題，可否做個實列讓我加速學習?謝謝
作者: PD961A    時間: 2010-5-19 13:52

本帖最後由 PD961A 於 2010-5-19 16:33 編輯

回復 3# y663258


    引用夏板主定義名稱
http://forum.twbts.com/viewthread.php?tid=251&extra=page%3D1
改成 A=OFFSET(Sheet1!$O$2,,,COUNTA(Sheet1!$O$2 : $O$25),3)                                
       N=OFFSET(sheet2!$B$5,COUNTA(Sheet2!$B$5 : $B$65536),)                                

Sub Macro1()        
    [A].Copy [N]'複製到        
    [A].ClearContents'清除        
End Sub        

另直接到閔版主給的網址下載111的檔案修正亦可:http://forum.twbts.com/viewthread.php?tid=251&extra=page%3D1
作者: y663258    時間: 2010-5-19 17:46

PD961A 謝謝示教經測試與我想要結果有不同，可能是我表達不好再說明Sheet1!O2:O35565(每次數量不一樣)COPY至Sheet2!B5，向下貼上並増減列與Sheet1!O2:O35565有資料列數同， 再將C5:AY5 公式同時向下貼上。
作者: Min    時間: 2010-5-19 21:25

PD961A 謝謝示教經測試與我想要結果有不同，可能是我表達不好再說明Sheet1!O2:O35565(每次數量不一樣)COPY至 ...
y663258 發表於 2010/5/19 05:46 PM





大概是這樣子! 其他的用錄製 因該都可以辦的到...

Sub test()
    Dim lS1RowEnd As Long
    Dim lS2RowEnd As Long
   
    lS1RowEnd = Worksheets("Sheet1").Range("Q65536").End(xlUp).Row
    lS2RowEnd = Worksheets("Sheet2").Range("B5").End(xlDown).Row + 1
   
    Worksheets("Sheet2").Rows(lS2RowEnd & ":" & lS1RowEnd + lS2RowEnd - 2).Insert Shift:=xlDown
   
    Worksheets("Sheet1").Range(Worksheets("Sheet1").Cells(2, 17), Worksheets("Sheet1").Cells(lS1RowEnd, 17)).Copy Worksheets("Sheet2").Cells(lS2RowEnd, 2)
End Sub
作者: Hsieh    時間: 2010-5-19 22:41

回復 5# y663258


    不知樓主是不是這個意思
  1. Sub Ex()
  2. Dim A As Range, Ar(31), Ay()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheet1
  5.    For Each A In .Range(.[P2], .[P65536].End(xlUp))
  6.    If A.Offset <> "" Then
  7.      If d(A.Value) = "" Then
  8.         d(A.Value) = A.Offset(, 1)
  9.         Else
  10.         d(A.Value) = d(A.Value) & "," & A.Offset(, 1)
  11.      End If
  12.     End If
  13.   Next
  14. End With
  15. For Each ky In d.keys
  16.    mystr = Split(d(ky), ",")
  17.        Ar(0) = ky: Ar(1) = "95-013-4-001": Ar(3) = "大型"
  18.        For i = 0 To UBound(mystr)
  19.           Ar(i + 4) = mystr(i)
  20.        Next
  21.        If d(ky) <> "" Then
  22.         Ar(24) = Mid(mystr(0), 1, 2): Ar(26) = Val(Mid(mystr(0), 1, 2)): Ar(27) = Mid(mystr(0), 1, 2)
  23.         Ar(28) = Mid(mystr(0), 1, 2) * 2: Ar(29) = 373.5: Ar(30) = Ar(28) * Ar(29) / 100000
  24.        End If
  25.    ReDim Preserve Ay(x)
  26.    Ay(x) = Ar
  27.    x = x + 1
  28.    Erase Ar
  29. Next
  30. Sheet2.[C5:Ay65536] = ""
  31. Sheet2.[B5].Resize(x, 31) = Application.Transpose(Application.Transpose(Ay))
  32. End Sub
複製代碼
作者: y663258    時間: 2010-5-21 00:09

Hsieh 版主謝謝經測試完全正確,不好意識我在附檔中把sheet2  z5即程式瑪ar(24)誤值為該列第一位,正確[attach]789[/attach]是最大值,其餘需求如附檔說明，敬請協助再此感恩。
作者: Hsieh    時間: 2010-5-21 11:49

回復 8# y663258


    超過Y欄的數量要自動增減會有困難
光是表頭就要重繪
其餘問題請參考
  1. Sub Ex()
  2. Dim A As Range, Ar(31), Ay()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With Sheet1
  5.    For Each A In .Range(.[P2], .[P65536].End(xlUp))
  6.    If A.Offset <> "" Then
  7.      If d(A.Value) = "" Then
  8.         d(A.Value) = A.Offset(, 1)
  9.         Else
  10.         d(A.Value) = d(A.Value) & "," & A.Offset(, 1)
  11.      End If
  12.     End If
  13.   Next
  14. End With
  15. For Each ky In d.keys
  16.    mystr = Split(d(ky), ",")
  17.        Ar(0) = "第一期" & ky: Ar(1) = "95-013-4-001": Ar(3) = "大型"
  18.        For i = 0 To UBound(mystr)
  19.           Ar(i + 4) = mystr(i)
  20.        Next
  21.        If d(ky) <> "" Then
  22.         Ar(24) = mystr(UBound(mystr)): Ar(26) = Val(Mid(mystr(0), 1, 2)): Ar(27) = Mid(mystr(0), 1, 2)
  23.         Ar(28) = Mid(mystr(0), 1, 2) * 2: Ar(29) = 373.5: Ar(30) = Ar(28) * Ar(29) / 100000
  24.        End If
  25.    ReDim Preserve Ay(x)
  26.    Ay(x) = Ar
  27.    x = x + 1
  28.    Erase Ar
  29. Next
  30. Sheet2.[B5:Ay65536] = ""
  31. Sheet2.[B5].Resize(x, 31) = Application.Transpose(Application.Transpose(Ay))
  32. End Sub
複製代碼
作者: y663258    時間: 2010-5-21 19:43

HSIEH兄
           Ar(24) = mystr(UBound(mystr)): Ar(26) = Val(Mid(mystr(0), 1, 2)): Ar(27) = Mid(mystr(0),
Ar(26)要改取Ar(24) = mystr(UBound(mystr)): 的左起2位,如23045取23謝謝指導
作者: y663258    時間: 2010-5-25 12:04

經更改 Ar(26) = Val(Mid(Ar(24), 1, 2))可以符合需求，以上謝謝二位版主。



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)