麻辣家族討論版版 - Powered by Discuz! Board

標題: 請問SHEET轉換紀錄的問題 [打印本頁]

作者: tonycho33 時間: 2012-2-14 15:55 標題: 請問SHEET轉換紀錄的問題

1.請問一下,如何將A SHEET存到B SHEET當J欄有出現任何值時對應的該列就會複製到B SHEET(空白處延伸)中

2.另一種是當按下按鈕時(對應工單號碼),則該工單對應的所有列就複製到B SHEET空白處

B SHEET要一直累加,不能留空白
謝謝

作者: GBKEE 時間: 2012-2-14 17:43

本帖最後由 GBKEE 於 2012-2-14 17:46 編輯

回復 1# tonycho33
***[D1:F1] 不可為空白***

Sub Ex()'1.請問一下,如何將A SHEET存到B SHEET當J欄有出現任何值
Dim xText As String
xText = "<>" '
Data_Copy 10, xText
End Sub
Sub ExA() '2.另一種是當按下按鈕時(對應工單號碼),則該工單對應的所有列就複製到B SHEET空白處
Dim xText As String
xText = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text
Data_Copy 1, xText
End Sub
Private Sub Data_Copy(xF As Integer, xCriteria As String)
Dim Sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheet7 'Sheets("A")
.AutoFilterMode = False
.Range("a1").AutoFilter Field:=xF, Criteria1:=xCriteria
Set Sh = Sheets.Add
.UsedRange.SpecialCells(xlCellTypeVisible).Copy Sh.[a1]
Sh.UsedRange.Offset(1).Copy Sheet6.Cells(Rows.Count, "A").End(xlUp).Offset(1)
'Sheet6->Sheet("B")
Sh.Delete
.AutoFilterMode = False
.Activate
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

複製代碼

作者: tonycho33 時間: 2012-2-14 18:34

本帖最後由 tonycho33 於 2012-2-14 18:46 編輯

回復 2# GBKEE

請問『1.請問一下,如何將A SHEET存到B SHEET當J欄有出現任何值時對應的該列就會複製到B SHEET(空白處延伸)中』
有個問題第一次輸入J欄時某一格儲存格可以紀錄
第二次再輸入時，因為原本第一次還在，所以會在重複記錄到
可以判斷有重複的話就不會紀錄嗎
另外請問
Data_Copy 10, xText

Data_Copy 1, xText
為什麼是1和10差在哪

謝謝

作者: GBKEE 時間: 2012-2-14 20:54

回復 3# tonycho33
"第二次再輸入時，因為原本第一次還在，所以會在重複記錄到"
你又沒說有篩選過的要刪掉 !!!
.Range("a1").AutoFilter Field:=xF, Criteria1:=xCriteria
Range("a1").AutoFilter: 在 A1橫向的欄位 [A1:J1] 自動篩選
Field:=1 :篩選的欄位 ->A欄 ; Field:=10 :篩選的欄位 ->J 欄

作者: tonycho33 時間: 2012-2-15 08:17

本帖最後由 tonycho33 於 2012-2-15 10:36 編輯

回復 4# GBKEE

真不好意思
非常感謝你的指導
請問『有篩選重複的要刪掉』要如何修改
讓B sheet 出現單一的對應欄位就好

Sub 刪除重複1()
Dim i As Long
Application.ScreenUpdating = False
For i = Range("a65536").End(xlUp).Row To 3 Step -1
If WorksheetFunction.CountIf(Range("a2:a" & i), Cells(i, 1)) > 1 Then
Cells(i, 1).EntireRow.Delete
End If
Next
Application.ScreenUpdating = True
End Sub

複製代碼

這個是比對A欄重複的
如果我想改比對A欄＆C欄重複的要如何修改呢
謝謝

作者: register313 時間: 2012-2-15 11:07

回復 5# tonycho33

超版,版主大概是沒有作不出來的問題
重點是希望發問者:
1.事先作好功課,把希望的功能描述清楚,不要反反覆覆,改來改去(幾次後真的沒人想幫)
2.附上EXCEL檔案,數據應把所有可能的情形都考慮進來

SHEET B之K欄不可有資料
同一工單若有的完成,有的未完成有時會分開顯示(應可接受吧)

Sub Ex() '1.將A SHEET存到B SHEET 當J欄有出現任何值
Dim xText As String
xText = "<>"
Data_Copy 10, xText
End Sub
Sub ExA() '2.按下按鈕時(對應工單號碼),該工單對應的所有列就複製到B SHEET空白處
Dim xText As String
xText = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text
Data_Copy 1, xText
End Sub
Private Sub Data_Copy(xF As Integer, xCriteria As String)
Dim Sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheet7 'Sheets("A")
.AutoFilterMode = False
.Range("a1").AutoFilter Field:=xF, Criteria1:=xCriteria
Set Sh = Sheets.Add
.UsedRange.SpecialCells(xlCellTypeVisible).Copy Sh.[a1]
Sh.UsedRange.Offset(1).Copy Sheet6.Cells(Rows.Count, "A").End(xlUp).Offset(1)
'Sheet6->Sheet("B")
Sh.Delete
.AutoFilterMode = False
.Activate
End With
Call deleterow '刪除B工作表之重覆列
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub deleterow() '刪除B工作表之重覆列
With Sheet6
R = .[A65536].End(xlUp).Row
For RM = 2 To R
For MM = 1 To 9 'SHEET B之K欄不可有資料
.Cells(RM, 11) = .Cells(RM, 11) & .Cells(RM, MM)
Next MM
Next RM
For I = 2 To R Step 1
If (WorksheetFunction.CountIf(.Columns(11), .Cells(I, 11)) > 1) Then
.Rows(I).Delete
I = I - 1
End If
Next
.Columns(11) = ""
End With
End Sub

複製代碼

[attach]9592[/attach]

作者: GBKEE 時間: 2012-2-15 11:08

回復 5# tonycho33

Private Sub Data_Copy(xF As Integer, xCriteria As String)
Dim Sh As Worksheet, Rng(1 To 2) As Range, xRow As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheet7 'Sheets("A")
.AutoFilterMode = False
.Range("a1").AutoFilter Field:=xF, Criteria1:=xCriteria
Set Rng(1) = .UsedRange.SpecialCells(xlCellTypeVisible)
If Application.CountA(Rng(1)) = Rng(1).Columns.Count Then
.AutoFilterMode = False
MsgBox IIf(xCriteria <> "<>", "找不到工單 :" & xCriteria, "完成時間沒有的資料")
GoTo e
End If
Set Sh = Sheets.Add
Rng(1).Copy Sh.[a1]
Sh.UsedRange.Offset(1).Copy Sheet6.Cells(Rows.Count, "A").End(xlUp).Offset(1)
Sh.Delete
.AutoFilterMode = False
.Activate
For Each xRow In Rng(1).Rows.Cells
If xRow.Row <> 1 Then
If Rng(2) Is Nothing Then
Set Rng(2) = xRow
Else
Set Rng(2) = Union(xRow, Rng(2))
End If
End If
Next
Rng(2).Delete xlShiftUp
End With
e:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

複製代碼

作者: tonycho33 時間: 2012-2-16 10:27

回復 7# GBKEE

不好意思可以在請教一個類似的問題嗎
我想將aa sheet記錄到bb sheet
條件是在aa sheet對應的t 欄有出現值的話
就將對應的A到R欄往下3列複製到bb sheet
但是資料還要保留/不要刪除

例如：當T3出現"已排程"時則A3到R5 三列copy到bb sheet中空格處
但是A3到R5不要刪除
接下來就以此類推可以仿照這樣記錄

謝謝

作者: GBKEE 時間: 2012-2-16 10:58

回復 8# tonycho33
當T3出現"已排程"時則
SHEETS("AA") T欄中都沒有資料啊

作者: tonycho33 時間: 2012-2-16 11:11

回復 9# GBKEE

麻煩謝謝

作者: register313 時間: 2012-2-16 11:42

回復 10# tonycho33

Sub QQ()
BR = 2
With Sheets("aa")
For AR = 3 To [A65536].End(xlUp).Row Step 3
If .Cells(AR, "T") = "已排程" Then
.Cells(AR, "A").Resize(3, 19).Copy Sheets("bb").Cells(BR, "A")
BR = BR + 3
End If
Next AR
End With
End Sub

複製代碼

作者: GBKEE 時間: 2012-2-16 12:58

回復 10# tonycho33
請問如圖

[attach]9613[/attach]

作者: tonycho33 時間: 2012-2-16 13:45

本帖最後由 tonycho33 於 2012-2-16 15:43 編輯

回復 12# GBKEE
回復 11# register313
F欄是資料欄,隱藏錯了
E欄是預留欄位

請教一下
之前詢問過的問題要彙整
aa→bb 是當T欄輸入『已排程』則匯入bb,並可以一筆一筆新增,已ok
bb→cc 目前是只能欄位轉換,可否當bb有新增時,cc也可以一筆一筆新增,請協助
就是當aa新增一筆T欄輸入『已排程』,該筆3列會轉入bb最後3列,之後轉換到cc時,只轉這一筆,不會全部一起轉換,並排在最下方
cc→dd 則是之前提問的功能,可以一筆一筆新增dd,已ok

所以麻煩第二項功能可以協助
謝謝

作者: register313 時間: 2012-2-16 18:05

回復 13# tonycho33

a按鈕(aa->bb)拿掉 b按鈕(bb->cc)拿掉 (不能自己用按鈕控制)
=> 當aa工作表T欄新增1個"已排程"時,自動新增到bb工作表及cc工作表

[attach]9620[/attach]

作者: tonycho33 時間: 2012-2-16 22:47

回復 14# register313

感謝協助,這樣的做法的確比我想得還好很多
感謝

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