請問要如何使用EXCEL VBA 自動把特定範圍的值找到再貼到另一個工作表?? (第2頁)

Mystique Hsiao

Mystique Hsiao
個人積分：7623分
文章編號：59765893

7623分

11樓

2016-04-07 14:59

turion111 wrote:
現在想在d欄後每四欄自動計算工作時間到分鐘

最簡單的方式就是將 D 欄儲存格設為『hh:mm』格式，
另外可採用下面的方式，
將Ｄ欄計算出的加總 *24*60 轉換為分鐘值！

原因請參考這篇

My Interior Knowledge is Extraordinaire

turion111

turion111
個人積分：102分
文章編號：59767272

102分

樓主

2016-04-07 16:40

我在網路上找到可以產生hh:mm效果的程式碼
在迴圈中加入一行後就可以了!!

For a = 4 To 34
Sheets(2).Range("d" & a & "") = (Sheets(2).Range("c" & a & "") - Sheets(2).Range("b" & a & ""))
'格式化時間為hh:mm
Sheets(2).Range("d" & a & "") = Format(Sheets(2).Range("d" & a & ""), "hh:mm")
Next a

snare

snare
個人積分：3057分
文章編號：59769364

3057分

13樓

2016-04-07 20:08

turion111 wrote:
我在網路上找到可以...(恕刪)

厲害，經過 Mystique Hsiao 高人，指點一下，您馬上就找到方法了

順便修正一下，我程式碼中有3個不理想的地方，因為會產生太多無用的空白資料

一、這行改成這樣
ReDim temparray(Sheets("sheet1").Range("a1:a" & Sheets("sheet1").Range("A1").End(xlDown).Row).SpecialCells(xlCellTypeVisible).Count - 1)

二、這行改成這樣
Sheets("sheet1").AutoFilter.Range.Offset(1, 0).Resize(Sheets("sheet1").AutoFilter.Range.Rows.Count, 4).SpecialCells(xlCellTypeVisible).Copy Sheets("sheet2").Cells(2, ((j - 1) * 5) + 1)

三、j=J+1 下，多加一行
If namedata = "" Then Exit For

'另外…如果要把資料分類到不同工作表，j=j+1 以下，換成這4行
If namedata = "" Then Exit For
Sheets.Add(After:=Sheets(Sheets.Count)).name = "_" & namedata & "_"
Sheets("sheet1").Range("a1:a" & Range("A1").End(xlDown).Row).AutoFilter Field:=1, Criteria1:=namedata
Sheets("sheet1").AutoFilter.Range.Offset(1, 0).Resize(Sheets("sheet1").AutoFilter.Range.Rows.Count, 4).SpecialCells(xlCellTypeVisible).Copy Sheets("_" & namedata & "_").Cells(4, 1)

'刪除除了 sheet1 之外的所有工作表，程式第一行加上 call dellsheet
Sub delsheet()

Dim delsheet As Worksheet
Application.DisplayAlerts = False
For Each delsheet In Worksheets

If delsheet.name 不等於 "Sheet1" Then delsheet.Delete '不等於，請自行改成符號
Next delsheet
Application.DisplayAlerts = True

End Sub

turion111 wrote:
For a = 4 To 34...(恕刪)

34 可用 Sheets("sheet1").AutoFilter.Range.Rows.SpecialCells(xlCellTypeVisible).Count + 2 代替
不過，整個迴圈要放在主程式中最後一個next上一行(倒數第3行)才行

turion111

turion111
個人積分：102分
文章編號：59773390

102分

樓主

2016-04-08 8:16

我使用錄製巨集的功能產生的程式碼
再修改一下成功計算出所有員工一個月的工時
然後再使用巨集將劃線加排版成A5大小的功能也加上來

現在有個問題是時薪的部份無法做分級
只能寫固定數值在程式內!!

還有A1儲存格會產生XFD1-XFC1不知道是程式那個位置出差一直找不到
請各位幫忙找一下!!

Sub copydata()
Dim temparray() As Variant
Worksheets("Sheet2").Cells.Clear
Sheets("sheet1").Range("a1:a" & Sheets("sheet1").Range("A1").End(xlDown).Row).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
ReDim temparray(Sheets("sheet1").Range("a1:a" & Sheets("sheet1").Range("A1").End(xlDown).Row).SpecialCells(xlCellTypeVisible).Count - 1)
For Each namedata In Sheets("sheet1").Range("a1:a" & Sheets("sheet1").Range("A1").End(xlDown).Row).SpecialCells(xlCellTypeVisible)
i = i + 1: If i > 1 Then temparray(i - 2) = namedata
Next
For Each namedata In temparray
j = j + 1
If namedata = "" Then Exit For
Sheets("sheet1").Range("a1:a" & Range("A1").End(xlDown).Row).AutoFilter Field:=1, Criteria1:=namedata
Sheets("sheet1").AutoFilter.Range.Offset(0, 1).Resize(Sheets("sheet1").AutoFilter.Range.Rows.Count, 4).SpecialCells(xlCellTypeVisible).Copy Sheets("sheet2").Cells(3, ((j - 1) * 4) + 1)
k = k + 4
Worksheets("Sheet2").Cells(1, k) = namedata
Next
Sheets("sheet1").AutoFilterMode = False

For x = 4 To 36 Step 4
For a = 4 To 34
ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-2]"
Worksheets("Sheet2").Cells(a, x) = Worksheets("Sheet2").Cells(a - 1, x) - Worksheets("Sheet2").Cells(a - 2, x)
Worksheets("Sheet2").Cells(a, x).Select

'格式化時間為hh:mm
Selection.NumberFormatLocal = "[hh]:mm"
Next a
Next x

'總時數計算
For b = 2 To 34 Step 4
Worksheets("Sheet2").Cells(2, b).Select
Worksheets("Sheet2").Cells(2, b) = Application.WorksheetFunction.Sum(Worksheets("Sheet2").Range(Cells(4, b + 2), Cells(34, b + 2)))
Worksheets("Sheet2").Cells(2, b).Select

'格式化時間為hh:mm
Selection.NumberFormatLocal = "[hh]:mm"

Worksheets("Sheet2").Cells(2, b + 1) = "薪資"
Worksheets("Sheet2").Cells(2, b - 1) = "總時數"
Worksheets("Sheet2").Cells(35, b + 1) = "勞健保含6%"
Worksheets("Sheet2").Cells(35, b + 2) = 1500

'計算薪資
Worksheets("Sheet2").Cells(2, b + 2) = Worksheets("Sheet2").Cells(2, b) * 100 * 24 + Worksheets("Sheet2").Cells(35, b + 2)
Worksheets("Sheet2").Cells(2, b + 2).Select
'薪資計算至整數
Selection.NumberFormatLocal = "0_ "
Next b

'畫線及排版
Cells.Select
Selection.ColumnWidth = 12
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.590551181102362)
.RightMargin = Application.InchesToPoints(0.590551181102362)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 200
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA5
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.590551181102362)
.RightMargin = Application.InchesToPoints(0.590551181102362)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 200
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA5
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
With Selection.Font
.Name = "新細明體"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Rows("1:34").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Cells.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

End Sub

snare

snare
個人積分：3057分
文章編號：59793012

3057分

15樓

2016-04-09 23:25

turion111 wrote:
還有A1儲存格會產生XFD1-XFC1不知道是程式那個位置出差一直找不到...(恕刪)

這裡，刪掉就好，您大概是錄巨集不小心錄到的
ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-2]"

順便教一下除錯方法
在認為可能出錯的地方，選一行程式碼，左邊灰色的空白處，滑鼠點一下

會出現一個“暗紅色”的圓點，那就是中斷點(可以很多個)
執行程式時，會暫時停在那裡

接下來，按 F8 ，一次執行一行程式
這樣就可以很容易找出那裡出錯了

turion111 wrote:
'畫線及排版
Cells.Select...(恕刪)

這 167 行程式碼，要不要考慮一下，改用以下這5行代替

Sheets("sheet2").PageSetup.PaperSize = xlPaperA5
Sheets("sheet2").Cells.Select
Selection.RowHeight = 13
Selection.ColumnWidth = 13
Sheets("sheet2").Range("a1").Select

turion111

turion111
個人積分：102分
文章編號：59816839

102分

樓主

2016-04-12 9:01

未註解ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-2]"
s的值有算出來

註解ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-2]"
s的值變0

snare wrote:
這裡，刪掉就好，您大概是錄巨集不小心錄到的
ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-2]"

我將這行放到計算式下面後就可以解決在a1儲存格出現的問題了!!

另外再請教一下!!
我如果excel將它開在非sheet2的頁面上，會產生程式碼出錯
若是在sheet2下執行就可以正常執行程式
請問問題是出在那裡??
附上檔案給大家玩玩!!
附加壓縮檔: 201604/mobile01-45a7855ad630a0b8675489a3fb4a32ff.zip

snare

snare
個人積分：3057分
文章編號：59826863

3057分

17樓

2016-04-12 21:55

turion111 wrote:
我如果excel將它開在非sheet2的頁面上，會產生程式碼出錯
若是在sheet2下執行就可以正常執行程式...(恕刪)

???

turion111 wrote:
現在有個問題是時薪的部份無法做分級
只能寫固定數值在程式內!!...(恕刪)

sheet3 那個，用 vlookup
跟這篇，使用者名稱、密碼的方法，差不多
http://www.mobile01.com/topicdetail.php?f=511&t=4682761

如果不要 sheet3 ，那就要用 select case 分類

turion111

turion111
個人積分：102分
文章編號：59830642

102分

樓主

2016-04-13 9:20

snare wrote:
用 select case 分類(恕刪)

感謝，用select case 就解決了!!

'計算薪資
For b = 2 To 36 Step 4
For c = 3 To 9
money = Worksheets("Sheet3").Cells(c, 3)

Select Case money
Case Is = 135
Worksheets("Sheet2").Cells(2, b + 2) = Worksheets("Sheet2").Cells(2, b) * 135 * 24 + Worksheets("Sheet2").Cells(35, b + 2)
Case Is = 130
Worksheets("Sheet2").Cells(2, b + 2) = Worksheets("Sheet2").Cells(2, b) * 130 * 24 + Worksheets("Sheet2").Cells(35, b + 2)
Case Is = 125
Worksheets("Sheet2").Cells(2, b + 2) = Worksheets("Sheet2").Cells(2, b) * 125 * 24 + Worksheets("Sheet2").Cells(35, b + 2)
Case Is = 120
Worksheets("Sheet2").Cells(2, b + 2) = Worksheets("Sheet2").Cells(2, b) * 120 * 24 + Worksheets("Sheet2").Cells(35, b + 2)
Case Is = 115
Worksheets("Sheet2").Cells(2, b + 2) = Worksheets("Sheet2").Cells(2, b) * 115 * 24 + Worksheets("Sheet2").Cells(35, b + 2)
Case Is = 110
Worksheets("Sheet2").Cells(2, b + 2) = Worksheets("Sheet2").Cells(2, b) * 110 * 24 + Worksheets("Sheet2").Cells(35, b + 2)
Case Is = 105
Worksheets("Sheet2").Cells(2, b + 2) = Worksheets("Sheet2").Cells(2, b) * 105 * 24 + Worksheets("Sheet2").Cells(35, b + 2)
Case Is = 100
Worksheets("Sheet2").Cells(2, b + 2) = Worksheets("Sheet2").Cells(2, b) * 100 * 24 + Worksheets("Sheet2").Cells(35, b + 2)
End Select

If Worksheets("Sheet2").Cells(2, b) = Worksheets("Sheet3").Cells(c, 2) Then Exit For '判斷sheet2和sheet3時數相同所對應的時薪

Next c
Worksheets("Sheet2").Cells(2, b + 2).Select

Selection.NumberFormatLocal = "0_ " '薪資計算至整數
Next b