Excel වැඩක්.

pathaleiretta · May 18, 2023

එක්සෙල් ෆයිල් එකක් තියෙනවා ඉමේජස් 1000+ මට ඕන මේ ඉමේජස් ටික ඒ පිලිවෙලටම වෙනම ෆෝල්ඩර් එකකට ගන්න. මන් මේ වගේ එකක් කලින් කලා Chat GPT එකෙන් පයිතන් Code එකක් හදලා වැඩේ කියන්නෙ Chat GPT එකට දැන් එක කරගන්න බෑ. හදපු එක කෝඩ් එකකින් වත් වැඩේ වෙන්නෙ නෑ. කලින් හදපු කෝඩ් එක මන් චේන්ජස් වගයක් කරා බැකප් එකක් තියාගන්න බැරි උනා. මේක කරගන්න විදියක් නැද්ද සින්හලු ඊයේ පැයගානක් ට්‍රයි කලා Chat GPT එකත් එක්ක.

Excel Sample

hasithayad · May 18, 2023

ඕකට vba code එකක් ලියන්න ඕනෙ බන්

pathaleiretta · May 18, 2023

hasithayad said:
ඕකට vba code එකක් ලියන්න ඕනෙ බන්

vba Coe ekakuth try kala harigiye na. me images pick karanne na ban code eken.

hasithayad · May 18, 2023

pathaleiretta said:
vba Coe ekakuth try kala harigiye na. me images pick karanne na ban code eken.

එක පාරින් වැඩකරා බන්. මෙතන active sheet එකේ හැම image එකක්ම ගන්නවා. range එකක් select කරන්න නැහැ

Code:

    Dim shp As Shape, ImageName As String, Temp As Object, tArea As Object, x As Long
    Application.ScreenUpdating = False
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoPicture Then
            x = x + 1
            shp.Select
            Application.Selection.CopyPicture
            Set Temp = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height)
            Set tArea = Temp.Chart
            Temp.Activate
            With tArea
                .ChartArea.Select
                .Paste
                .Export ("C:\Users\user\Documents\excel_img\img-" & x & ".jpg")
            End With
            Temp.Delete
            DoEvents
        End If
    Next

thesasindu · May 18, 2023

ChatGPT eke histroy eken ganna barid bn code eka?

shenat · May 18, 2023

Bing eken try karapan code eka.
Chat gpt free ekata wada hodai

hasithayad · May 18, 2023

col A එකේ value එක filename එකට එන්න හැදුවා

Code:

Dim shp As Shape, ImageName As String, Temp As Object, tArea As Object, x As Long
    Application.ScreenUpdating = False
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoPicture Then
        Dim col_A_value As String
        col_A_value = ActiveSheet.Cells(Range(shp.TopLeftCell.Address).Row, 1)
            shp.Select
            Application.Selection.CopyPicture
            Set Temp = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height)
            Set tArea = Temp.Chart
            Temp.Activate
            With tArea
                .ChartArea.Select
                .Paste
                .Export ("C:\Users\user\Documents\excel_img\" & col_A_value & ".jpg")
            End With
            Temp.Delete
            DoEvents
        End If
    Next

kasun090354t · May 18, 2023

hasithayad said:

col A එකේ value එක filename එකට එන්න හැදුවා

Code:

Dim shp As Shape, ImageName As String, Temp As Object, tArea As Object, x As Long
    Application.ScreenUpdating = False
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoPicture Then
        Dim col_A_value As String
        col_A_value = ActiveSheet.Cells(Range(shp.TopLeftCell.Address).Row, 1)
            shp.Select
            Application.Selection.CopyPicture
            Set Temp = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height)
            Set tArea = Temp.Chart
            Temp.Activate
            With tArea
                .ChartArea.Select
                .Paste
                .Export ("C:\Users\user\Documents\excel_img\" & col_A_value & ".jpg")
            End With
            Temp.Delete
            DoEvents
        End If
    Next

මෙ මචෝ. ඔය sheet එකේ තියන ඔක්කොම shapes read කරන්නේ නැතිව අපි දෙන range එකේ shapes තියනවද කියලා හොයන්න ක්‍රමයක් නැද්ද? Intersect වෙනවද කියන එකෙන් බලන්න දන්නවා. එක කරන්නත් sheet එකේ තියන ඔක්කොම shapes read කරනවානේ.
සරලවම ඇහුවොත් ඔය for loop එක sheet එකට නැතිව දෙන range එකකට run කරන්න බැරිද?

hasithayad · May 18, 2023

kasun090354t said:
මෙ මචෝ. ඔය sheet එකේ තියන ඔක්කොම shapes read කරන්නේ නැතිව අපි දෙන range එකේ shapes තියනවද කියලා හොයන්න ක්‍රමයක් නැද්ද? Intersect වෙනවද කියන එකෙන් බලන්න දන්නවා. එක කරන්නත් sheet එකේ තියන ඔක්කොම shapes read කරනවානේ.
සරලවම ඇහුවොත් ඔය for loop එක sheet එකට නැතිව දෙන range එකකට run කරන්න බැරිද?

පුලුවන් ඇති බන්. ට්‍රයි එකක් දීලා බලන්නම්

pathaleiretta · May 18, 2023

hasithayad said:

col A එකේ value එක filename එකට එන්න හැදුවා

Code:

Dim shp As Shape, ImageName As String, Temp As Object, tArea As Object, x As Long
    Application.ScreenUpdating = False
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoPicture Then
        Dim col_A_value As String
        col_A_value = ActiveSheet.Cells(Range(shp.TopLeftCell.Address).Row, 1)
            shp.Select
            Application.Selection.CopyPicture
            Set Temp = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height)
            Set tArea = Temp.Chart
            Temp.Activate
            With tArea
                .ChartArea.Select
                .Paste
                .Export ("C:\Users\user\Documents\excel_img\" & col_A_value & ".jpg")
            End With
            Temp.Delete
            DoEvents
        End If
    Next

ado ekama thamay mata ona une. try ekak dila kiyannam, Meged cells tiyeddi awulak wena ekak nane?

kasun090354t · May 18, 2023

hasithayad said:
පුලුවන් ඇති බන්. ට්‍රයි එකක් දීලා බලන්නම්

මාත් දැන් සැහෙන කාලයක් තිස්සේ try කරනවා. බැරි උනේ ඔකයි userform කක් මට ඔනේ තැනින් open කරගන්නයි. ඒ කියන්නේ එකේ position එක excel sheet එකේ මට ඔනේ තැනින්.

hasithayad · May 18, 2023

pathaleiretta said:
ado ekama thamay mata ona une. try ekak dila kiyannam, Meged cells tiyeddi awulak wena ekak nane?

එල එල. Meged cells තියෙද්දි ඒක ඇතුලේ තියන image එකට, ඒ image එකේ TopLeftCell එකේ තියන value එක තමයි සෙට් වෙන්නෙ

kasun090354t said:
මාත් දැන් සැහෙන කාලයක් තිස්සේ try කරනවා. බැරි උනේ ඔකයි userform කක් මට ඔනේ තැනින් open කරගන්නයි. ඒ කියන්නේ එකේ position එක excel sheet එකේ මට ඔනේ තැනින්.

ඒක කරන්න අමාරුයි මචන්. Intersect පාවිච්චි කරන එක තමයි ලේසිම වැඩේ. තව එක විදියයි තියෙන්නේ. ඒක තමයි cell range එකක් Worksheet object එකකට convert කරගෙන ඒ cell range එක worksheet එකක් විදියට පාවිච්චි කරලා වැඩේ කරන එක. chatgpt එකෙන් ගත්තෙ :sorry:

Code:

Sub ConvertRangeToWorksheet()
    Dim rng As Range
    Dim ws As Worksheet
    
    Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:B10") ' Replace "Sheet1" with your sheet name and "A1:B10" with your range address
    Set ws = rng.Worksheet
    
    ' Now you can work with the worksheet object (ws)
    ' For example:
    ws.Activate
    ' ... perform other operations on the worksheet ...
End Sub

------ Post added on May 18, 2023 at 6:07 PM

kasun090354t · May 18, 2023

hasithayad said:
එල එල. Meged cells තියෙද්දි ඒක ඇතුලේ තියන image එකට, ඒ image එකේ TopLeftCell එකේ තියන value එක තමයි සෙට් වෙන්නෙ

ඒක කරන්න අමාරුයි මචන්. Intersect පාවිච්චි කරන එක තමයි ලේසිම වැඩේ. තව එක විදියයි තියෙන්නේ. ඒක තමයි cell range එකක් Worksheet object එකකට convert කරගෙන ඒ cell range එක worksheet එකක් විදියට පාවිච්චි කරලා වැඩේ කරන එක. chatgpt එකෙන් ගත්තෙ

Code:

Sub ConvertRangeToWorksheet() Dim rng As Range Dim ws As Worksheet Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:B10") ' Replace "Sheet1" with your sheet name and "A1:B10" with your range address Set ws = rng.Worksheet ' Now you can work with the worksheet object (ws) ' For example: ws.Activate ' ... perform other operations on the worksheet ... End Sub

------ Post added on May 18, 2023 at 6:07 PM

එල එල මන් බලන්න ම්.

මුගෙ වැඩේට. මර්ජ් කරලා තියන cells වලට range වලින් ලියන කෝඩ් වැඩ කරන්නේ නැතිව යනවා. පුලුවන් තරම් cells වලින්ම ලියන්න ඔනේ. අර topleftcell එකේ row එක කෙලින්ම ගන්න පුලුවන් නේද, range එකේ address එක ගන්නේ නැතිව.

hasithayad · May 18, 2023

kasun090354t said:
එල එල මන් බලන්න ම්.

මුගෙ වැඩේට. මර්ජ් කරලා තියන cells වලට range වලින් ලියන කෝඩ් වැඩ කරන්නේ නැතිව යනවා. පුලුවන් තරම් cells වලින්ම ලියන්න ඔනේ. අර topleftcell එකේ row එක කෙලින්ම ගන්න පුලුවන් නේද, range එකේ address එක ගන්නේ නැතිව.

ඔව් බන්. කෙලින්ම shape එකේ TopLeftCell.Address එකෙන් ඒක ගන්න පුලුවන්. ඒ ලයින් එක මම දැම්මෙ A column එකේ අදාල cell value එක අරගන්න. Range පාවිච්චි නොකර කෙලින්ම cell value එක අරගන්න ක්‍රමයක් තියනවද දන්නෑ.

EKGuest · May 18, 2023

මචන් @hasithayad ගේ VBA කෝඩ් එකෙන් එකේ හැම ඉමේජ් එකක්ම සේව් කරගන්න පුලුවන්. මම ඒ කෝඩ් එකම පොඩ්ඩක් වෙනස් කලා එක එක ඉමේජ් එක අදාල Item Code එකේ නමින් සේව් වෙන්න. උදාහරණයක් විදියට S004.jpg කියලා සේව් වෙන්නේ ඒ Item Code එකට අදාල ඉමේජ් එක.

මේකේ itemImageColumn එකට ඉමේජ් එක තියන කොලම් එකේ නම දෙන්න. itemCodeColumn වලට Item Code එක තියෙන කොලම් එකේ නම දෙන්න. saveInFolderName වලට ඉමේජ් ටික සේව් කරන්න ඕනෑ ෆොල්ඩර් එකේ පාත් එක දෙන්න.

Code:

 Sub SaveImages()

    Dim shp As Shape, ImageName As String, Temp As Object, tArea As Object, _
        itemCodeColumn As String, saveInFolderName As String
   
    itemImageColumn = "G"
    itemCodeColumn = "A"
    saveInFolderName = "C:\Users\Public\Images"
   
    Application.ScreenUpdating = False
    For Each shp In ActiveSheet.Shapes
        If shp.TopLeftCell.Column = Range(itemImageColumn & 1).Column Then
            If shp.Type = msoPicture Then
                shp.Select
                Application.Selection.CopyPicture
                Set Temp = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height)
                Set tArea = Temp.Chart
                Temp.Activate
                With tArea
                    .ChartArea.Select
                    .Paste
                    .Export (saveInFolderName & "\" & ActiveSheet.Range(itemCodeColumn & shp.TopLeftCell.Row).Value & ".jpg")
                End With
                Temp.Delete
                DoEvents
            End If
        End If
    Next
End Sub

pathaleiretta · May 18, 2023

hasithayad said:
එල එල. Meged cells තියෙද්දි ඒක ඇතුලේ තියන image එකට, ඒ image එකේ TopLeftCell එකේ තියන value එක තමයි සෙට් වෙන්නෙ

ඒක කරන්න අමාරුයි මචන්. Intersect පාවිච්චි කරන එක තමයි ලේසිම වැඩේ. තව එක විදියයි තියෙන්නේ. ඒක තමයි cell range එකක් Worksheet object එකකට convert කරගෙන ඒ cell range එක worksheet එකක් විදියට පාවිච්චි කරලා වැඩේ කරන එක. chatgpt එකෙන් ගත්තෙ

Code:

Sub ConvertRangeToWorksheet() Dim rng As Range Dim ws As Worksheet Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:B10") ' Replace "Sheet1" with your sheet name and "A1:B10" with your range address Set ws = rng.Worksheet ' Now you can work with the worksheet object (ws) ' For example: ws.Activate ' ... perform other operations on the worksheet ... End Sub

------ Post added on May 18, 2023 at 6:07 PM

ෆුල් ෆයිල් එකට රන් කරාම ඉමේජ් තුන්සිය ගානයි බන් අවෙ ඒකත් තැනින් තැන. කෝඩ් එක සේව් කරන්න ගියාමත් එරර්ස් වගයක් පෙන්නුව බන් VBA ෆ්‍රී සීන් එකක්. මේ ෆුල් ෆයිල් එකට කෝඩ් එක දාල දියන්කො Excel

මගේ බන් කෝඩ් එක සේව් කරාට මැක්‍රො ලිස්ට් එකට එන්නෙ නෑනෙ

EKGuest · May 18, 2023

pathaleiretta said:
ෆුල් ෆයිල් එකට රන් කරාම ඉමේජ් තුන්සිය ගානයි බන් අවෙ ඒකත් තැනින් තැන. කෝඩ් එක සේව් කරන්න ගියාමත් එරර්ස් වගයක් පෙන්නුව බන් VBA ෆ්‍රී සීන් එකක්. මේ ෆුල් ෆයිල් එකට කෝඩ් එක දාල දියන්කො Excel

මගේ බන් කෝඩ් එක සේව් කරාට මැක්‍රො ලිස්ට් එකට එන්නෙ නෑනෙ

මෙන්න ඉමේජස් ටික https://fastupload.io/k4jZ0zLCVsA1v8N/file

ඔක්කොම ඉමේජස් 1177 ක් තියෙනවා.

මම අර උඩ පෝස්ට් එකේ දාපු කෝඩ් එක රන් කලාම ඉමේජස් ටික ඔක්කොම ඔයා දීපු ෆෝල්ඩර් එක ඇතුලේ සේව් වෙනවා.

මෙන්න මැක්‍රෝ එක දාපු Excel ෆයිල් එක https://fastupload.io/GTeS2gk8jgKGQAG/file

hasithayad · May 18, 2023

pathaleiretta said:
ෆුල් ෆයිල් එකට රන් කරාම ඉමේජ් තුන්සිය ගානයි බන් අවෙ ඒකත් තැනින් තැන. කෝඩ් එක සේව් කරන්න ගියාමත් එරර්ස් වගයක් පෙන්නුව බන් VBA ෆ්‍රී සීන් එකක්. මේ ෆුල් ෆයිල් එකට කෝඩ් එක දාල දියන්කො Excel

මගේ බන් කෝඩ් එක සේව් කරාට මැක්‍රො ලිස්ට් එකට එන්නෙ නෑනෙ

මචන් බලපන් 1258, 1259 images දෙකම සෙට් වෙන්නේ 1258ට. 1093 j, images දෙකක් එකක් උඩ එකක් තියනවා. ඒවා නිසා වෙන්න ඕනෙ අවුල් යන්නෙ. මම @EKGuest ගේ කෝඩ් එක අප්ඩේට් කරා දාලා බලන්න. ඔක්කොම images 1178ක් සේව් වෙනවා

Code:

Dim shp As Shape, Temp As Object, tArea As Object, itemCodeColumn As String, saveInFolderName As String

itemImageColumn = "G"
itemCodeColumn = "A"
saveInFolderName = "C:\Users\user\Documents\excel_img"

Application.ScreenUpdating = False
MsgBox ("Total Images: " & ActiveSheet.Shapes.Count)
For Each shp In ActiveSheet.Shapes
On Error Resume Next
    If shp.TopLeftCell.Column = Range(itemImageColumn & 1).Column Then
        If shp.Type = msoPicture Then
            shp.Select
            Application.Selection.CopyPicture
            DoEvents
            Set Temp = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height)
            Set tArea = Temp.Chart
            Temp.Activate
            If Dir(saveInFolderName & "\" & ActiveSheet.Range(itemCodeColumn & shp.TopLeftCell.Row).Value & ".jpg") = "" Then
                With tArea
                    .ChartArea.Select
                    .Paste
                    .Export (saveInFolderName & "\" & ActiveSheet.Range(itemCodeColumn & shp.TopLeftCell.Row).Value & ".jpg")
                End With
            Else
                MsgBox ("Image Already exists: " & shp.TopLeftCell.Address)
            End If
            Temp.Delete
            DoEvents
        End If
    End If
If Err.Number > 0 Then
    MsgBox ("Error: No-" & Err.Number & vbCrLf & Err.Description & vbCrLf & "CELL: " & shp.TopLeftCell.Address)
    Err.Clear
End If
Next
MsgBox ("Complete")

Kalegana · May 18, 2023

bamp තමයි ඉතින්..

pathaleiretta · May 18, 2023

එ

hasithayad said:

මචන් බලපන් 1258, 1259 images දෙකම සෙට් වෙන්නේ 1258ට. 1093 j, images දෙකක් එකක් උඩ එකක් තියනවා. ඒවා නිසා වෙන්න ඕනෙ අවුල් යන්නෙ. මම @EKGuest ගේ කෝඩ් එක අප්ඩේට් කරා දාලා බලන්න. ඔක්කොම images 1178ක් සේව් වෙනවා

Code:

Dim shp As Shape, Temp As Object, tArea As Object, itemCodeColumn As String, saveInFolderName As String

itemImageColumn = "G"
itemCodeColumn = "A"
saveInFolderName = "C:\Users\user\Documents\excel_img"

Application.ScreenUpdating = False
MsgBox ("Total Images: " & ActiveSheet.Shapes.Count)
For Each shp In ActiveSheet.Shapes
On Error Resume Next
    If shp.TopLeftCell.Column = Range(itemImageColumn & 1).Column Then
        If shp.Type = msoPicture Then
            shp.Select
            Application.Selection.CopyPicture
            DoEvents
            Set Temp = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height)
            Set tArea = Temp.Chart
            Temp.Activate
            If Dir(saveInFolderName & "\" & ActiveSheet.Range(itemCodeColumn & shp.TopLeftCell.Row).Value & ".jpg") = "" Then
                With tArea
                    .ChartArea.Select
                    .Paste
                    .Export (saveInFolderName & "\" & ActiveSheet.Range(itemCodeColumn & shp.TopLeftCell.Row).Value & ".jpg")
                End With
            Else
                MsgBox ("Image Already exists: " & shp.TopLeftCell.Address)
            End If
            Temp.Delete
            DoEvents
        End If
    End If
If Err.Number > 0 Then
    MsgBox ("Error: No-" & Err.Number & vbCrLf & Err.Description & vbCrLf & "CELL: " & shp.TopLeftCell.Address)
    Err.Clear
End If
Next
MsgBox ("Complete")

එල. මන් බලන්නම්

Excel වැඩක්.

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Well-known member

Similar threads