تغییر سطر به ستون با vba

Collapse
این تاپیک قفل است.
X
X
Collapse
 
  • صفحه از 1
  • زمان
  • نمایش
حذف همه
new posts
قبلی template بعدی
  • Cookie

    • 2016/11/29
    • 31
    #1

    [حل شده] تغییر سطر به ستون با vba

    با سلام

    سوالی رو در قسمت پرسش و پاسخ مطرح کردم.
    دوستان گفتند که با vba میشه انجامش داد.
    جدولی دارم که در ستون ها سال و روز قرار گرفته و در سطر اسامی ماه ها.(فایل پیوست)
    در حال حاضر سال و روز در ستون هستند و ماه در سطر ... مثلا روز اول سال 135152 فقط در ماه خرداد مقدار داره ولی در روز دوم همون سال در ماه های فروردین و اسفند داده داره.

    می خوام اسامی ماه ها رو هم در ستون ها داشته باشم، یعنی گزارش گیری به این صورت باشه که هم سال هم ماه و هم روز در ستون ها قرار بگیرند و مقدار هم روبه روشون باشه. ولی برای انجام این کار جدول به کلی تغییر خواهد کرد.(چون اسامی ماه ها و روزها و سال ها تکرار بیشتری پیدا می کنند.)

    میشه دوستی لطف کنه و کدی بنویسیه که این کار رو انجام بده؟
    :63:

    فایل های پیوست شده
    Last edited by Cookie; 2017/04/14, 13:47.
    برچسب ها: هیچ‌کدام
    • rahi_feri

      • 2014/08/08
      • 524
      • 94.67
      #2
      سلام
      کد زیر رو در یک Module کپی و اجرا کنید!

      چک کنید اطلاع بدید!

      کد:
      Sub hey_you()
Application.ScreenUpdating = False
Dim N As Integer

ActiveWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
N = Sheets.Count
cnt = 1
For i = 2 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    For m = 3 To 14
        If Application.WorksheetFunction.Count(Sheets(1).Range("C" & i & ":N" & i)) = 0 Then
            Sheets(N).Range("A" & cnt).Value = Sheets(1).Cells(i, 1)
            Sheets(N).Range("B" & cnt).Value = Sheets(1).Cells(i, 2)
            cnt = cnt + 1
        ElseIf Sheets(1).Cells(i, m) <> "" Then
            Sheets(N).Range("A" & cnt).Value = Sheets(1).Cells(i, 1)
            Sheets(N).Range("B" & cnt).Value = Sheets(1).Cells(i, 2)
            Sheets(N).Range("C" & cnt).Value = Sheets(1).Cells(i, m)
            Sheets(N).Range("D" & cnt).Value = Sheets(1).Cells(1, m)
            cnt = cnt + 1
        End If
    Next m
Next

Application.ScreenUpdating = True

End Sub
      [B][SIZE=1]بخش امضاء :
      [/SIZE][/B][LEFT]
      [CODE]
      Sub Macro()
      ActiveCell = "IY" & Right(Application.Name, 5)
      With ActiveCell.Characters(Start:=2, Length:=1).Font
      .Name = "Webdings"
      .Color = 255
      End With
      End Sub
      [/CODE]
      [/LEFT]

        کامنت

        • Cookie

          • 2016/11/29
          • 31
          #3
          نوشته اصلی توسط rahi_feri
          سلام
          کد زیر رو در یک Module کپی و اجرا کنید!

          چک کنید اطلاع بدید!

          کد:
          Sub hey_you()
Application.ScreenUpdating = False
Dim N As Integer

ActiveWorkbook.Sheets.Add after:=Sheets(Sheets.Count)
N = Sheets.Count
cnt = 1
For i = 2 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    For m = 3 To 14
        If Application.WorksheetFunction.Count(Sheets(1).Range("C" & i & ":N" & i)) = 0 Then
            Sheets(N).Range("A" & cnt).Value = Sheets(1).Cells(i, 1)
            Sheets(N).Range("B" & cnt).Value = Sheets(1).Cells(i, 2)
            cnt = cnt + 1
        ElseIf Sheets(1).Cells(i, m) <> "" Then
            Sheets(N).Range("A" & cnt).Value = Sheets(1).Cells(i, 1)
            Sheets(N).Range("B" & cnt).Value = Sheets(1).Cells(i, 2)
            Sheets(N).Range("C" & cnt).Value = Sheets(1).Cells(i, m)
            Sheets(N).Range("D" & cnt).Value = Sheets(1).Cells(1, m)
            cnt = cnt + 1
        End If
    Next m
Next

Application.ScreenUpdating = True

End Sub
          سلام ..
          عالیییی، دقیقا همون که میخواستم ..
          خیلی خیلی ممنون ..🌹🌹🌹

            کامنت

            قبلی template بعدی
            چند لحظه..