نمایش نتایج: از شماره 1 تا 5 , از مجموع 5

موضوع: وارد کردن اطلاعات متناظر با یک ستون در ستون بعدی

  1. #1


    آخرین بازدید
    2020/01/12
    تاریخ عضویت
    June 2012
    نوشته ها
    11
    امتیاز
    2
    سپاس
    6
    سپاس شده
    2 در 2 پست
    سطح اکسل
    67.00 %

    Question وارد کردن اطلاعات متناظر با یک ستون در ستون بعدی

    با سلام
    دو ستون در اکسل دارم، ستون اول حاوی یک سری کد و ستون دوم حاوی کد های متناظر آن، در هر دو ستون تکراری وجود دارد ولی ترکیب دو ستون یکتا می باشد. (مانند جدول ذیل)

    کد کد متناظر
    A 1
    B 2
    C 3
    A 2
    C 4
    B 3
    A 5
    D 6
    D 2

    حال می خوام در شیت دیگر در ستون اول اطلاعات ستون اول (کد) به صورت یکتا قرار بگیرد. و در سلول متناظر آن کدهای ستون دوم (کد متناظر) با "-"از هم جدا شده و قرار بگیرد.
    به مثل جدول ذیل
    کد کدهای متناظر
    A 1-2-5
    D 2-6


    کارهایی که کردم این بوده: (شیت Data صفحه است که جدول اصلی در آن است، شیت Out صفحه است که میخواهم اطلاعات در آن وارد شود)

    کد:
        Sheets("Data").Select
        Dim LC As Integer
        LC = Cells(Rows.Count, 1).End(xlUp).Row
        Columns("A:A").Select
        Selection.Copy
        Sheets("Out").Select
        Columns("A:A").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveSheet.Range("$A$1:$A$" & LC).RemoveDuplicates Columns:=1, Header:=xlNo
    کد های این موضوع را هم دیدم ولی متوجه نشدم چطوری باید این کار رو انجام بدم.
    لطف می کنید راهنمایی کنید؟
    اخطار: این یک موضوع قدیمی است
    به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.
    پاسخ مورد نظر براي اين تاپيك ارسال شده است.

  2.  

  3. #2


    آخرین بازدید
    2019/04/13
    تاریخ عضویت
    September 2014
    نوشته ها
    38
    امتیاز
    22
    سپاس
    6
    سپاس شده
    12 در 9 پست
    تعیین سطح نشده است

    با سلام
    خدمت شما ، امیدوارم به دردتون بخوره
    بدون محدودیت سطر و ستون
    فقط فاصله کلمه S cripting رو در متن بردارید و سپس استفاده کنید
    خروجی به این صورت میشه
    برای دیدن سایز بزرگ روی عکس کلیک کنید

نام:  GetUniquesAndFindCategory.JPG
مشاهده: 12
حجم:  87.0 کیلو بایت

    [
    کد:
    'With Respect
    'Here You Are
    Sub GetUniquesAndFindCategory()
        Dim cel As Range, cel2 As Range
        Dim cat As String
        
        sep = "_"
            
        Dim d As Object, c As Variant, i As Long, lr As Long
        Set d = CreateObject("S cripting.Dictionary")
        lr = Cells(Rows.Count, 1).End(xlUp).Row
        c = Range("A2:A" & lr)
            For i = 1 To UBound(c, 1)
              d(c(i, 1)) = 1
            Next i
            Columns("F:F").Select
            Selection.ClearContents
            Range("F2").Resize(d.Count) = Application.Transpose(d.keys)
        'Option For Delete Blanks
            Columns("F:F").Select
            Selection.SpecialCells(xlCellTypeBlanks).Select
            Selection.Delete Shift:=xlUp
            Range("A1").Select
            For Each cel In Range("F1:F" & lr)
                For Each cel2 In Range("A2:A" & lr)
                    If cel2.Value = cel.Value Then cat = cat & sep & cel2.Offset(, 1).Value
                Next cel2
                cel.Offset(, 1).Value = Right(cat, Len(cat) - Len(sep))
                cat = ""
            Next cel
        Cells.Select
        Cells.EntireColumn.AutoFit
        With Selection
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
        End With
        Columns("G:G").Select
        With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
        End With
        
    End Sub
    ویرایش توسط mahdi2013 : 2018/02/24 در ساعت 16:24

  4. سپاس ها (2)


  5. #3


    آخرین بازدید
    2020/01/12
    تاریخ عضویت
    June 2012
    نوشته ها
    11
    امتیاز
    2
    سپاس
    6
    سپاس شده
    2 در 2 پست
    سطح اکسل
    67.00 %

    نقل قول نوشته اصلی توسط mahdi2013 نمایش پست ها
    با سلام
    خدمت شما ، امیدوارم به دردتون بخوره
    بدون محدودیت سطر و ستون
    فقط فاصله کلمه S cripting رو در متن بردارید و سپس استفاده کنید
    خروجی به این صورت میشه
    برای دیدن سایز بزرگ روی عکس کلیک کنید

نام:  GetUniquesAndFindCategory.JPG
مشاهده: 12
حجم:  87.0 کیلو بایت

    [
    کد:
    'With Respect
    'Here You Are
    Sub GetUniquesAndFindCategory()
        Dim cel As Range, cel2 As Range
        Dim cat As String
        
        sep = "_"
            
        Dim d As Object, c As Variant, i As Long, lr As Long
        Set d = CreateObject("S cripting.Dictionary")
        lr = Cells(Rows.Count, 1).End(xlUp).Row
        c = Range("A2:A" & lr)
            For i = 1 To UBound(c, 1)
              d(c(i, 1)) = 1
            Next i
            Columns("F:F").Select
            Selection.ClearContents
            Range("F2").Resize(d.Count) = Application.Transpose(d.keys)
        'Option For Delete Blanks
            Columns("F:F").Select
            Selection.SpecialCells(xlCellTypeBlanks).Select
            Selection.Delete Shift:=xlUp
            Range("A1").Select
            For Each cel In Range("F1:F" & lr)
                For Each cel2 In Range("A2:A" & lr)
                    If cel2.Value = cel.Value Then cat = cat & sep & cel2.Offset(, 1).Value
                Next cel2
                cel.Offset(, 1).Value = Right(cat, Len(cat) - Len(sep))
                cat = ""
            Next cel
        Cells.Select
        Cells.EntireColumn.AutoFit
        With Selection
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
        End With
        Columns("G:G").Select
        With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
        End With
        
    End Sub
    با سلام و تشکر از شما
    چند مسئله دارم فقط:
    1- اول اینکه هرکاری میکنم، نمی تونم بهش بفهمونم توی یک شیت دیگه خروجی را (به جای ستون F , G همون شیت) وارد کند.
    2- سطر شامل عبارت ذیل ارور میدهد ولی خروجی اش درست است!
    کد:
    cel.Offset(, 1).Value = Right(cat, Len(cat) - Len(sep))

  6. #4


    آخرین بازدید
    2019/04/13
    تاریخ عضویت
    September 2014
    نوشته ها
    38
    امتیاز
    22
    سپاس
    6
    سپاس شده
    12 در 9 پست
    تعیین سطح نشده است

    خدمت شما
    چنانچه به جواب رسیدین کلید Solved فراموش نشه .

    - - - Updated - - -

    کد:
    'With Respect
    'Here You Are
    Sub GetUniquesAndFindCategory()
        Dim cel As Range, cel2 As Range
        Dim cat As String
        
        sep = "_"
            
        Dim d As Object, c As Variant, i As Long, lr As Long
        Set d = CreateObject("S cripting.Dictionary")
        lr = Cells(Rows.Count, 1).End(xlUp).Row
        c = Range("A2:A" & lr)
            For i = 1 To UBound(c, 1)
              d(c(i, 1)) = 1
            Next i
            Worksheets("Sheet2").Select
            Columns("F:F").Select
            Selection.ClearContents
            Range("F2").Resize(d.Count) = Application.Transpose(d.keys)
        'Option For Delete Blanks
            Columns("F:F").Select
            Selection.SpecialCells(xlCellTypeBlanks).Select
            Selection.Delete Shift:=xlUp
            Range("A1").Select
            For Each cel In Range("F1:F" & lr)
                For Each cel2 In Worksheets("Sheet1").Range("A2:A" & lr)
                    If cel2.Value = cel.Value Then cat = cat & sep & cel2.Offset(, 1).Value
                Next cel2
                Worksheets("Sheet2").Select
                cel.Offset(, 1).Value = Right(cat, Len(cat) - Len(sep))
                cat = ""
            Next cel
        Cells.Select
        Cells.EntireColumn.AutoFit
        With Selection
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
        End With
        Columns("G:G").Select
        With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
        End With
        
    End Sub

  7. سپاس ها (2)


  8. #5


    آخرین بازدید
    2020/01/12
    تاریخ عضویت
    June 2012
    نوشته ها
    11
    امتیاز
    2
    سپاس
    6
    سپاس شده
    2 در 2 پست
    سطح اکسل
    67.00 %

    با سپاس و تشکر فراوان از شما...

    نقل قول نوشته اصلی توسط mahdi2013 نمایش پست ها
    خدمت شما
    چنانچه به جواب رسیدین کلید Solved فراموش نشه .

    - - - Updated - - -

    کد:
    'With Respect
    'Here You Are
    Sub GetUniquesAndFindCategory()
        Dim cel As Range, cel2 As Range
        Dim cat As String
        
        sep = "_"
            
        Dim d As Object, c As Variant, i As Long, lr As Long
        Set d = CreateObject("S cripting.Dictionary")
        lr = Cells(Rows.Count, 1).End(xlUp).Row
        c = Range("A2:A" & lr)
            For i = 1 To UBound(c, 1)
              d(c(i, 1)) = 1
            Next i
            Worksheets("Sheet2").Select
            Columns("F:F").Select
            Selection.ClearContents
            Range("F2").Resize(d.Count) = Application.Transpose(d.keys)
        'Option For Delete Blanks
            Columns("F:F").Select
            Selection.SpecialCells(xlCellTypeBlanks).Select
            Selection.Delete Shift:=xlUp
            Range("A1").Select
            For Each cel In Range("F1:F" & lr)
                For Each cel2 In Worksheets("Sheet1").Range("A2:A" & lr)
                    If cel2.Value = cel.Value Then cat = cat & sep & cel2.Offset(, 1).Value
                Next cel2
                Worksheets("Sheet2").Select
                cel.Offset(, 1).Value = Right(cat, Len(cat) - Len(sep))
                cat = ""
            Next cel
        Cells.Select
        Cells.EntireColumn.AutoFit
        With Selection
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
        End With
        Columns("G:G").Select
        With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
        End With
        
    End Sub


اطلاعات موضوع

کاربرانی که در حال مشاهده این موضوع هستند

در حال حاضر 1 کاربر در حال مشاهده این موضوع است. (0 کاربران و 1 مهمان ها)

موضوعات مشابه

  1. [حل شده] جمع مبالغ یک ستون در صورتی که ستون کناری با مشخصه خاصی باشد از طریق if
    توسط mohanad-arch در انجمن توابع اکسل - Excel Functions
    پاسخ ها: 8
    آخرين نوشته: 2016/12/06, 08:29
  2. پاسخ ها: 3
    آخرين نوشته: 2015/11/08, 13:05
  3. [حل شده] جستجوی یک ستون و انتقال سلولهایی که متن آنها با کلمه خاصی شروع می شود به ستون دیگر
    توسط hasanr در انجمن سوالات پیرامون ويژوال بيسيك - VBA Questions
    پاسخ ها: 25
    آخرين نوشته: 2015/05/19, 12:32
  4. پاسخ ها: 5
    آخرين نوشته: 2015/01/22, 00:23
  5. پاسخ ها: 1
    آخرين نوشته: 2010/12/30, 08:29

بازدید کنندگان با جستجو های زیر این صفحه را پیدا کرده اند

انجمن اكسل ايران , اكسل , اكسس , سوال و جواب اكسل , سوال اكسس , انجمن اكسل ايران , توابع اكسل, آموزش اكسل, آموزش اكسس, VBA, ويژوال بيسيك

کلمات کلیدی این موضوع

علاقه مندی ها (Bookmarks)

مجوز های ارسال و ویرایش

  • شما نمیتوانید موضوع جدیدی ارسال کنید
  • شما امکان ارسال پاسخ را ندارید
  • شما نمیتوانید فایل پیوست کنید.
  • شما نمیتوانید پست های خود را ویرایش کنید
  •  
  • BB code ها فعال هستند
  • شکلک ها فعال هستند
  • کد [IMG] فعال است
  • کد [VIDEO] فعال است
  • کد HTML غیر فعال است
با ما در تماس باشيد