- Katılım
- 30 Mart 2019
- Mesajlar
- 54
- Excel Vers. ve Dili
- 2016 Türkçe
- Altın Üyelik Bitiş Tarihi
- 09-04-2020
Merhaba, @veyselemre tekrardan kendisine teşekkür ederim. Bana bir makro yazdı. Başka bir örnek için yazdığından dolayı yeni örneğimde bu makroyu kullanamıyorum. Sizlerden ricam bir bakabilirmisiniz. Makronun uygulandığı EXCEL ÖRNEĞİ. Bu örnek de belirtilen yoldan dosyayı seçiyor ve oraya yazdırıyor. Ama ben bu makroyu, BU EXCELDE ki İkram ve Satılan alanlarına yazdırmak istiyorum. Yardımcı olursanız çok sevinirim.
Makro Kodu;
Makro Kodu;
Kod:
Sub sayfaDuzenle()
'veyselEMRE 06042019
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = "C:\BiletiniAl\Reports\*Büfe*Rapor*.xls"
If .Show = -1 Then fileopen = .SelectedItems(1)
End With
If fileopen <> "" Then
Set wb = Workbooks.Open(fileopen, ReadOnly:=True)
Set sf = wb.Sheets("Sheet")
With Intersect(sf.UsedRange, sf.Columns("G"))
If WorksheetFunction.CountBlank(.Cells) > 0 Then
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
End With
With Intersect(sf.UsedRange, sf.Columns("F"))
If WorksheetFunction.CountBlank(.Cells) > 0 Then
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End If
End With
sf.Columns("A:E").Delete Shift:=xlToLeft
sf.Columns("C:D").Delete Shift:=xlToLeft
sf.Rows("1").Delete Shift:=xlToLeft
With Intersect(sf.UsedRange, sf.Columns("B"))
For Each huc In .Cells
If huc.Value = "Yönetim Misafir" Then
huc.Value = huc.Offset(, 1).Value
huc.Offset(, 1).ClearContents
Else
huc.Value = ""
End If
Next
End With
lst = sf.UsedRange
wb.Close False
End If
With CreateObject("Scripting.Dictionary")
Dim w(1 To 1, 1 To 2)
For i = LBound(lst) To UBound(lst)
ky = lst(i, 1)
If Not .exists(ky) Then .Item(ky) = w
y = .Item(ky)
If lst(i, 2) <> "" Then y(1, 1) = lst(i, 2)
If lst(i, 3) <> "" Then y(1, 2) = lst(i, 3)
.Item(ky) = y
Next i
son = Cells(Rows.Count, 1).End(3).Row
Range("B2:G" & son).ClearContents
For i = 2 To son
ky = Cells(i, 1).Value
If .exists(ky) Then
Cells(i, 2).Resize(, 2).Value = .Item(ky)
.Remove ky
End If
Next i
If .Count > 0 Then
kys = .keys
itm = .items
[E2].Value = "Hatalı Kayıtlar"
For i = LBound(kys) To UBound(kys)
Cells(i + 3, "E").Value = kys(i)
Cells(i + 3, "F").Resize(, 2).Value = itm(i)
Next i
End If
End With
Columns.AutoFit
Application.Speech.Speak ("OK")
End Sub