ساخت ديتابيس به كمك اكسل

[afshin3a]

سلام بر اساتيد گرامي!
در فايل پيوست extractor.xlsx, متغيير هاي من نام، نام خانوادگي و دانشگاه هستند. اگر در شيت Data دقت كنيد متغييرهايي ديگري مانند شغل هم داريم كه اونا به درد من نمي خورند. ميخوام به اكسل بگم كه هرجا اين متغييرها رو ديدي، مقدار جلوي اونو جدا كن و به شيت بعدي منتقل كن و يك ديتابيس اونجا بساز! خوشبختانه تمام متغييرام جلوشون علامت ":" هست. با چه ماكرويي بايد اين كار رو كرد؟

[iranweld]

با سلام

یک ماکرو اولیه برای شما تهیه گردید

Sub test()

On Error Resume Next

K = 2

Z1 = Application.WorksheetFunction.CountA(Sheet1.Range("1:1"))

For J = 1 To Z1

Z2 = Sheet1.Cells(Sheet1.Rows.Count, J).End(xlUp).Row

For i = 1 To Z2

xx = Cells(i, J)
ZZ = Cells(i, J).Offset(1, 0)



yy = InStr(1, xx, "Material Name:")

If yy >= 1 Then

Sheet2.Range("A" & K) = K - 1

Sheet2.Range("B" & K) = Right(xx, Len(Cells(i, J)) - 15)

Sheet2.Range("C" & K) = Right(ZZ, Len(ZZ) - 12)

K = K + 1

Exit For

End If

Next

Next


End Sub 

[afshin3a]

بسيار ممنون از پاسختون و وقتي كه گذاشتين.. مشكل من هم همينه. بعضي جاها متغييرها پشت سر هم نيستن.

[iranweld]

با سلام
در فایل جدید مشکل برطرف شد

Sub test()

Macro1

On Error Resume Next

K = 2

z1 = Application.WorksheetFunction.CountA(Sheet1.Range("1:1"))


For J = 1 To z1

Z2 = Sheet1.Cells(Sheet1.Rows.Count, J).End(xlUp).Row

For i = 1 To Z2

xx = Cells(i, J)
zz = Cells(i, J).Offset(1, 0)



yy = InStr(1, xx, "Material Name:")

If yy >= 1 Then

Sheet2.Range("A" & K) = K - 1

Sheet2.Range("B" & K) = Right(xx, Len(Cells(i, J)) - 15)

End If


yy = InStr(1, xx, "Trade Name:")

If yy >= 1 Then

Sheet2.Range("C" & K) = Right(xx, Len(xx) - 12)

K = K + 1

Exit For

End If

Next

Next

Sheet2.Select

End Sub