• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Barkod ile ilgili yardım

E

excel5252

Altın Üye
Katılım
19 Ocak 2021
Mesajlar
47
Excel Vers. ve Dili
microsoft office 2019 tr 2004 olan seri son sürüm
Çok değerli Üstadlarım ekteki barkodla ilgili sorum şu ben ismi belirtilen barkoda nasıl yazdıra bilirim. Sütun E deki barkoda üstüne veya altın barkoda etki etmeden nasıl isim yazdıra bilirim. Şimdiden yardımlarınız için çok teşekkür ederim.
 

Ekli dosyalar

s.a.

Kod: 
Sub BarkodVeIsim()
    Dim i As Long
    Dim barkod As String, isim As String
   
    For i = 2 To Cells(Rows.Count, "E").End(xlUp).Row
        barkod = Cells(i, "E").Value
        isim = Cells(i, "F").Value ' Ürün isimleri F sütununda olsun
        Cells(i, "E").Value = barkod & vbNewLine & isim
        Cells(i, "E").WrapText = True
    Next i
End Sub

E sütununda barkod var.
F sütununda isim var.
Makro, E sütununa barkod + isim alt alta yazar.

Barkod fontunu ilk satıra elle uygularsan, isim normal fontta kalır.
 
airborne' Alıntı:
s.a.

Kod: 
Sub BarkodVeIsim()
    Dim i As Long
    Dim barkod As String, isim As String
  
    For i = 2 To Cells(Rows.Count, "E").End(xlUp).Row
        barkod = Cells(i, "E").Value
        isim = Cells(i, "F").Value ' Ürün isimleri F sütununda olsun
        Cells(i, "E").Value = barkod & vbNewLine & isim
        Cells(i, "E").WrapText = True
    Next i
End Sub

E sütununda barkod var.
F sütununda isim var.
Makro, E sütununa barkod + isim alt alta yazar.

Barkod fontunu ilk satıra elle uygularsan, isim normal fontta kalır.
Genişletmek için tıkla ...

sana zahmet olmaz ise bana makrolu şekilde verirmisin şimdiden teşekkür ederim.
 
üstadlar ben kitap birdeki barkod olan yeri yazdırırken adını nasıl yazdırta bilirim.
 
excel5252' Alıntı:
üstadlar ben kitap birdeki barkod olan yeri yazdırırken adını nasıl yazdırta bilirim.
Genişletmek için tıkla ...
Sizden Cevap Gelmedi ama anladığım Kadarıyla.. Geri dönüş Yapınki Çözüm mü Değilmi? bilelim
 

Ekli dosyalar

Son düzenleme:
nihatkr' Alıntı:
Sizden Cevap Gelmedi ama anladığım Kadarıyla.. Geri dönüş Yapınki Çözüm mü Değilmi? bilelim
Genişletmek için tıkla ...
Kusura kalma bugün gördüm
ben tablodaki borkod olan yerdeki kısmı yazdırırken üstüne veya alt kısma ismi nasıl yazdıra bilirim
 
nihatkr' Alıntı:
Son Gönderiğim dosya Bunu Yapıyor 10. Mesaj
Genişletmek için tıkla ...
peki üstad bunu nasıl çoğalta biliriz yani kişi sayısı 1500 geçerse nasıl olur farklı kişilerde oluyor mu.çünkü ben bunu başka bir listeyi kopyalayıp verdiğiniz programda end debug hatasında run time erro 404 hatası veriyor debug deyince de
wsHedef.Paste hatası ile sonuçlanıyor. şimdiden teşekkür ederim.
 
excel5252' Alıntı:
peki üstad bunu nasıl çoğalta biliriz yani kişi sayısı 1500 geçerse nasıl olur farklı kişilerde oluyor mu.çünkü ben bunu başka bir listeyi kopyalayıp verdiğiniz programda end debug hatasında run time erro 404 hatası veriyor debug deyince de
wsHedef.Paste hatası ile sonuçlanıyor. şimdiden teşekkür ederim.
Genişletmek için tıkla ...
Aslında Tüm Satırları kontrol ediyor. Ama Boş Staırlar Olunca Hata Veriyor.

Modül 3 teki kodu aşağıdaki KOD'la değiştirin sorun kalmayacak. (Test ettim çalışıyor sorun yok. Hem Bu Kod Hem Seçmeli Kod)

Sub TumListeBarkodTekResim()
Dim wsKaynak As Worksheet, wsHedef As Worksheet
Dim lastRow As Long, i As Long
Dim urunAdi As String, barkod As String
Dim imgURL As String
Dim tmpShp As Shape
Dim yeniSayfaAd As String
Dim pic As Picture
Dim tempFile As String

Set wsKaynak = ActiveSheet
yeniSayfaAd = "BarkodlarTekResim"

On Error Resume Next
Application.DisplayAlerts = False
Worksheets(yeniSayfaAd).Delete
Application.DisplayAlerts = True
On Error GoTo 0

Set wsHedef = Worksheets.Add
wsHedef.Name = yeniSayfaAd
wsHedef.Cells.Clear

wsHedef.Cells(1, 1).Value = "Ürün ve Barkod"
wsHedef.Rows(1).Font.Bold = True
wsHedef.Rows(1).RowHeight = 30

lastRow = wsKaynak.Cells(wsKaynak.Rows.Count, "A").End(xlUp).Row

Application.ScreenUpdating = False

For i = 2 To lastRow
urunAdi = wsKaynak.Cells(i, 1).Value
barkod = wsKaynak.Cells(i, 5).Value


If Trim(urunAdi) = "" Or Trim(barkod) = "" Then GoTo Sonraki

imgURL = "https://barcode.tec-it.com/barcode.ashx?data=" & barkod & _
"&code=Code128&multiplebarcodes=false&translate-esc=false&unit=Fit&dpi=96"


tempFile = Environ("TEMP") & "\tmpbarkod.png"


Dim WinHttp As Object
Set WinHttp = CreateObject("MSXML2.XMLHTTP")
WinHttp.Open "GET", imgURL, False
WinHttp.Send

If WinHttp.Status = 200 Then
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
stream.Type = 1
stream.Open
stream.Write WinHttp.responseBody
stream.SaveToFile tempFile, 2
stream.Close


Set tmpShp = wsHedef.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 200, 60)
With tmpShp
.TextFrame.Characters.Text = urunAdi
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignTop
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
End With


Set pic = wsHedef.Pictures.Insert(tempFile)
With pic
.Top = tmpShp.Top + 20
.Left = tmpShp.Left + 10
.ShapeRange.LockAspectRatio = msoTrue
.Height = 40
End With


wsHedef.Shapes.Range(Array(tmpShp.Name, pic.Name)).Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
wsHedef.Cells(i, 1).Select
wsHedef.Paste


tmpShp.Delete
pic.Delete


Kill tempFile

wsHedef.Rows(i).RowHeight = 60
End If

Sonraki:
Next i

Application.ScreenUpdating = True
MsgBox "Tüm barkodlar tek resim olarak '" & yeniSayfaAd & "' sayfasına eklendi!", vbInformation
End Sub
 
nihatkr' Alıntı:
Aslında Tüm Satırları kontrol ediyor. Ama Boş Staırlar Olunca Hata Veriyor.

Modül 3 teki kodu aşağıdaki KOD'la değiştirin sorun kalmayacak. (Test ettim çalışıyor sorun yok. Hem Bu Kod Hem Seçmeli Kod)

Sub TumListeBarkodTekResim()
Dim wsKaynak As Worksheet, wsHedef As Worksheet
Dim lastRow As Long, i As Long
Dim urunAdi As String, barkod As String
Dim imgURL As String
Dim tmpShp As Shape
Dim yeniSayfaAd As String
Dim pic As Picture
Dim tempFile As String

Set wsKaynak = ActiveSheet
yeniSayfaAd = "BarkodlarTekResim"

On Error Resume Next
Application.DisplayAlerts = False
Worksheets(yeniSayfaAd).Delete
Application.DisplayAlerts = True
On Error GoTo 0

Set wsHedef = Worksheets.Add
wsHedef.Name = yeniSayfaAd
wsHedef.Cells.Clear

wsHedef.Cells(1, 1).Value = "Ürün ve Barkod"
wsHedef.Rows(1).Font.Bold = True
wsHedef.Rows(1).RowHeight = 30

lastRow = wsKaynak.Cells(wsKaynak.Rows.Count, "A").End(xlUp).Row

Application.ScreenUpdating = False

For i = 2 To lastRow
urunAdi = wsKaynak.Cells(i, 1).Value
barkod = wsKaynak.Cells(i, 5).Value


If Trim(urunAdi) = "" Or Trim(barkod) = "" Then GoTo Sonraki

imgURL = "https://barcode.tec-it.com/barcode.ashx?data=" & barkod & _
"&code=Code128&multiplebarcodes=false&translate-esc=false&unit=Fit&dpi=96"


tempFile = Environ("TEMP") & "\tmpbarkod.png"


Dim WinHttp As Object
Set WinHttp = CreateObject("MSXML2.XMLHTTP")
WinHttp.Open "GET", imgURL, False
WinHttp.Send

If WinHttp.Status = 200 Then
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
stream.Type = 1
stream.Open
stream.Write WinHttp.responseBody
stream.SaveToFile tempFile, 2
stream.Close


Set tmpShp = wsHedef.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 200, 60)
With tmpShp
.TextFrame.Characters.Text = urunAdi
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignTop
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
End With


Set pic = wsHedef.Pictures.Insert(tempFile)
With pic
.Top = tmpShp.Top + 20
.Left = tmpShp.Left + 10
.ShapeRange.LockAspectRatio = msoTrue
.Height = 40
End With


wsHedef.Shapes.Range(Array(tmpShp.Name, pic.Name)).Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
wsHedef.Cells(i, 1).Select
wsHedef.Paste


tmpShp.Delete
pic.Delete


Kill tempFile

wsHedef.Rows(i).RowHeight = 60
End If

Sonraki:
Next i

Application.ScreenUpdating = True
MsgBox "Tüm barkodlar tek resim olarak '" & yeniSayfaAd & "' sayfasına eklendi!", vbInformation
End Sub
Genişletmek için tıkla ...

çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst