- Katılım
- 4 Mayıs 2007
- Mesajlar
- 234
- Excel Vers. ve Dili
-
office 2007 64 bit
office 2010 64 bit
- Altın Üyelik Bitiş Tarihi
- 14-09-2023
iyi günler arkadaşlar,
userform1 üzerinde 100 tane buton var ve her bir buton bir sayfa için buton 1 e tıklandıgında userform2 nin içindeki gönder butonun kodundaki Sheets("SAYFA1").Select buton 2 ye tıkladıgımda ise Sheets("SAYFA2").Select olması münkün mü aceba. eğer mümkün ise butona nasıl bi kod eklemem gereklidir aceba...
Değiştirmek istediğim bölge aşşağıdaki kodda KIRMIZ renkli olan yerdir.
saygılarımla..
Private Sub GÖNDER1_Click()
Sheets("BEKLEME").Select
Range("A66").Select
Selection.Copy
Sheets("PRİNT").Select
Range("A11").Select
ActiveSheet.Paste
Sheets("BEKLEME").Select
Range("A4").Select
Selection.Copy
Sheets("PRİNT").Select
Range("C2").Select
ActiveSheet.Paste
With Selection.Font
.Size = 8
End With
Range("A2") = Format(Now, "hh:mm")
Application.ScreenUpdating = False
Range("A11").Select
Application.CutCopyMode = False
With Selection.Font
.Name = "Arial"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim i, S2sonsat, S1sonsat
Set S1 = Sheets("ANA")
Set S2 = Sheets("BEKLEME")
Set S3 = Sheets("PRİNT")
s3_sat = 3
s2_son = S2.[B65536].End(3).Row - 1
For i = 11 To s2_son
For a = 1 To 400
If S2.Cells(i, "B") = S1.Cells(a, "b") Then
S3.Cells(s3_sat, "a") = S2.Cells(i, "a")
S3.Cells(s3_sat, "b") = S2.Cells(i, "b")
s3_sat = s3_sat + 1
Else: End If
Next a
Next i
Set S1 = Nothing
Set S3 = Nothing
Set S2 = Nothing
s3_sat = Empty
s2_son = Empty
i = Empty
a = Empty
Application.ScreenUpdating = True
Sheets("PRİNT").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Columns("A").Select
Range("A2").Activate
Selection.ClearContents
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A11").Select
Sheets("BEKLEME").Select
Dim c As Range, sat As Long
Set c = [A:A].Find("y")
If Not c Is Nothing Then
sat = c.Row
End If
If sat = 11 Then Exit Sub
Rows("11:" & sat - 1).Copy
Sheets("SAYFA1").Select
Rows("11:11").Select
Selection.Insert Shift:=xlDown
ActiveSheet.PasteSpecial
Dim X, son
son = Cells(Rows.Count, "D").End(3).Row
If son <= 11 Then Exit Sub
For X = son To 11 Step -1
Cells(X, 1) = WorksheetFunction.SumIf(Range("B:B"), Cells(X, "B"), Range("A:A"))
Cells(X, 4) = WorksheetFunction.SumIf(Range("B:B"), Cells(X, "B"), Range("D"))
If WorksheetFunction.CountIf(Range("B" & son & ":B" & X), Cells(X, "B")) > 1 Then
Rows(X).Delete
End If
Next
Range("E1").Select
Sheets("BEKLEME").Select
Range("A11").Select
If sat = 11 Then Exit Sub
Rows("11:" & sat - 1).Delete Shift:=xlUp
Unload Me
End Sub
userform1 üzerinde 100 tane buton var ve her bir buton bir sayfa için buton 1 e tıklandıgında userform2 nin içindeki gönder butonun kodundaki Sheets("SAYFA1").Select buton 2 ye tıkladıgımda ise Sheets("SAYFA2").Select olması münkün mü aceba. eğer mümkün ise butona nasıl bi kod eklemem gereklidir aceba...
Değiştirmek istediğim bölge aşşağıdaki kodda KIRMIZ renkli olan yerdir.
saygılarımla..
Private Sub GÖNDER1_Click()
Sheets("BEKLEME").Select
Range("A66").Select
Selection.Copy
Sheets("PRİNT").Select
Range("A11").Select
ActiveSheet.Paste
Sheets("BEKLEME").Select
Range("A4").Select
Selection.Copy
Sheets("PRİNT").Select
Range("C2").Select
ActiveSheet.Paste
With Selection.Font
.Size = 8
End With
Range("A2") = Format(Now, "hh:mm")
Application.ScreenUpdating = False
Range("A11").Select
Application.CutCopyMode = False
With Selection.Font
.Name = "Arial"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Dim S1 As Worksheet
Dim S2 As Worksheet
Dim i, S2sonsat, S1sonsat
Set S1 = Sheets("ANA")
Set S2 = Sheets("BEKLEME")
Set S3 = Sheets("PRİNT")
s3_sat = 3
s2_son = S2.[B65536].End(3).Row - 1
For i = 11 To s2_son
For a = 1 To 400
If S2.Cells(i, "B") = S1.Cells(a, "b") Then
S3.Cells(s3_sat, "a") = S2.Cells(i, "a")
S3.Cells(s3_sat, "b") = S2.Cells(i, "b")
s3_sat = s3_sat + 1
Else: End If
Next a
Next i
Set S1 = Nothing
Set S3 = Nothing
Set S2 = Nothing
s3_sat = Empty
s2_son = Empty
i = Empty
a = Empty
Application.ScreenUpdating = True
Sheets("PRİNT").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Columns("A").Select
Range("A2").Activate
Selection.ClearContents
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A11").Select
Sheets("BEKLEME").Select
Dim c As Range, sat As Long
Set c = [A:A].Find("y")
If Not c Is Nothing Then
sat = c.Row
End If
If sat = 11 Then Exit Sub
Rows("11:" & sat - 1).Copy
Sheets("SAYFA1").Select
Rows("11:11").Select
Selection.Insert Shift:=xlDown
ActiveSheet.PasteSpecial
Dim X, son
son = Cells(Rows.Count, "D").End(3).Row
If son <= 11 Then Exit Sub
For X = son To 11 Step -1
Cells(X, 1) = WorksheetFunction.SumIf(Range("B:B"), Cells(X, "B"), Range("A:A"))
Cells(X, 4) = WorksheetFunction.SumIf(Range("B:B"), Cells(X, "B"), Range("D"))
If WorksheetFunction.CountIf(Range("B" & son & ":B" & X), Cells(X, "B")) > 1 Then
Rows(X).Delete
End If
Next
Range("E1").Select
Sheets("BEKLEME").Select
Range("A11").Select
If sat = 11 Then Exit Sub
Rows("11:" & sat - 1).Delete Shift:=xlUp
Unload Me
End Sub