CopyFromSelectedWorkbookToThisWorkbook

 Sub CopyFromSelectedWorkbookToThisWorkbook()

    Dim sourceWB As Workbook

    Dim targetWB As Workbook

    Dim sourceWS As Worksheet

    Dim targetWS As Worksheet

    Dim copyRange As Range

    Dim lastRow As Long, lastCol As Long

    Dim filePath As Variant

    ' Set reference to the target workbook and Sheet1

    Set targetWB = ThisWorkbook

    'Set targetWS = targetWB.ActiveSheet

    Set targetWS = targetWB.Sheets("Sheet1")

    targetWS.cells.clear

    ' Prompt user to select the source workbook (.xls or .xlsx)

    filePath = Application.GetOpenFilename("Excel Files (*.xls; *.xlsx), *.xls; *.xlsx", , "Select Source Workbook")

    ' Exit if user cancels

    If filePath = False Then

        MsgBox "No file selected.", vbExclamation

        Exit Sub

    End If

    ' Open the source workbook

    Set sourceWB = Workbooks.Open(filePath)

    Set sourceWS = sourceWB.ActiveSheet

    ' Find the last used row and column in source sheet

    lastRow = sourceWS.Cells(sourceWS.Rows.Count, 2).End(xlUp).Row

    lastCol = sourceWS.Cells(lastRow, sourceWS.Columns.Count).End(xlToLeft).Column

    ' Define the range to copy

    Set copyRange = sourceWS.Range(sourceWS.Cells(1, 1), sourceWS.Cells(lastRow, lastCol))

    ' Paste the copied range into Sheet1

    copyRange.Copy

    targetWS.Range("A1").PasteSpecial Paste:=xlPasteAll

    ' Optional: Close the source workbook without saving

    sourceWB.Close SaveChanges:=False

    ' Clear clipboard

    Application.CutCopyMode = False

End Sub

ExportToCSV

 Sub ExportToCSV()

    Dim ws As Worksheet

    Dim exportRange As Range

    Dim lastRow As Long

    Dim filePath As String

    ' Set the worksheet (change Sheet10 to your actual sheet name if needed)

    Set ws = ThisWorkbook.ActiveSheet

    ' Find the last row with data in column A

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

    ' Define the range to export (A1 to D[lastRow])

    Set exportRange = ws.Range("A1:D" & lastRow)

    ' Set the file path (you can change this to your desired location)

    filePath = Application.ThisWorkbook.Path & "\ExportedData.csv"

    ' Export the range to CSV

    Open filePath For Output As #1

    Dim r As Range, cell As Range

    For Each r In exportRange.Rows

        Dim line As String

        line = ""

        For Each cell In r.Cells

            line = line & cell.Text & vbTab

        Next cell

        ' Remove trailing tab

        If Len(line) > 0 Then line = Left(line, Len(line) - 1)

        Print #1, line

    Next r

    Close #1

    MsgBox "Data exported to CSV successfully!" & vbCrLf & filePath, vbInformation

End Sub

excel forward backward seq

B2=INPUT
B3 =INDEX(A1:G1, MOD(MATCH(B2, A1:G1, 0), COLUMNS(A1:G1)) + 1)

B4=INDEX(A1:G1, IF(MATCH(B2, A1:G1, 0)=1, COLUMNS(A1:G1), MATCH(B2, A1:G1, 0)-1))

VBA select area to export to picture and set name same sheet name

 Sub ExportAllSheets()

    Dim oWs As Worksheet

    Dim oRng As Range

    Dim oChrtO As ChartObject

    Dim lWidth As Long, lHeight As Long

    Dim sFilePath As String

    

    sFilePath = "d:\"

    

    For Each oWs In ActiveWorkbook.Worksheets

        ActiveWindow.Zoom = 100

        Set oRng = oWs.Range("B2:n30")

        

        oRng.CopyPicture xlScreen, xlPicture

        lWidth = oRng.Width

        lHeight = oRng.Height

        

        Set oChrtO = oWs.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)

        

        oChrtO.Activate

        With oChrtO.chart

            .Paste

            .Export Filename:=sFilePath & oWs.Name & ".jpg", Filtername:="JPG"

        End With

        

        oChrtO.Delete

    Next oWs

End Sub

Excel โชว์ข้อมูลจากการเลือก หลายเงื่อนไข

 

Input E1 find "AAA or BBB"

E2,E3

=IFERROR(INDEX($B$2:$B$11, SMALL(IF(INDEX($C$2:$D$11,,MATCH($E$1,$C$1:$D$1,0))>0, ROW($B$2:$B$11)-MIN(ROW($B$2:$B$11))+1), ROW(1:1))), "")

Code from Copliot help

multi sum condition combine right hand

 A           B         C         D         E

1   Month   Region     Jan      Feb      Mar      Apr

2   Sales      S          100      150      200      250

3   Sales      N          100      150      200      250

4   Profit     S          50        75      100      125

5   Profit     N          50        75      100      125

=SUMPRODUCT((ISNUMBER(MATCH(C1:E1,{"Feb","Mar"},0)))*(B2:B5="S")*(A2:A5="Profit")*(C2:E5))

example: select folder to open each file and find data --> save to another file

Sub find_error()

    Dim oFSO As Object

    Dim oFolder As Object

    Dim oFile As Object

    Dim FldrPicker As FileDialog

    Dim myFolder As String

    Dim File_Open As Workbook

    

    'Have User Select Folder to Save to With Dialog Box

    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    

    With FldrPicker

        .Title = "Select A Target Folder"

        .AllowMultiSelect = False

        If .Show <> -1 Then Exit Sub 'Check If user clicked cancel button

            myFolder = .SelectedItems(1) & "\"

    End With

        

    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Set oFolder = oFSO.GetFolder(myFolder)

    Application.ScreenUpdating = False

    

    a = 7

    For Each oFile In oFolder.Files

        If InStr(1, oFile.Name, "xlsx") And Left(oFile.Name, 1) = "L" Then

            Set File_Open = Workbooks.Open(oFile.Path)

            For n = 1 To File_Open.Sheets.Count

                If Not File_Open.Sheets(n).Name = "IPM-BSM-SA" Then

                    'File_Open.Sheets(n).Select

                    If InStr(1, File_Open.Sheets(n).Cells(1, 1), "Logging Data Inspection") Then

                        check = True

                        col = 1

                        While check

                            If InStr(1, File_Open.Sheets(n).Cells(3, col), "D3268") Or InStr(1, File_Open.Sheets(n).Cells(2, col), "D3268") Then

                                check = False

                                Else

                                col = col + 1

                            End If

                        Wend

                        i = 1

                        check = True

                        While check

                            If File_Open.Sheets(n).Cells(i, 1) = 1 Then

                                check = False

                            Else

                                i = i + 1

                            End If

                        Wend

                        While File_Open.Sheets(n).Cells(i, 2) <> ""

                            If InStr(1, UCase(File_Open.Sheets(n).Cells(i, col)), UCase("Angle_Error")) Then

                                File_Open.Sheets(n).Rows(i).Copy Destination:=Sheet1.Rows(a)

                                Sheet1.Cells(a, 51) = File_Open.Sheets(n).Name

                                a = a + 1

                            End If

                            i = i + 1

                        Wend

                    End If

                End If

            Next n

            File_Open.Close SaveChanges:=False

        End If

    Next oFile

    Application.ScreenUpdating = True

End Sub

Set variable in excel page (not vba)

 

1 select formula tab

2 select name manager icon

3 pop up name manager editor

VBA replace force Monthname in english format

monthname= Application.WorksheetFunction.Text(DateSerial(2017, a, 1), "[$-0409]mmmm")

VBA: Capture area excel export to picture file

 Function SavePicToFile(foto, area)

 Dim oWs As Worksheet

 Dim oRng As Range

 Dim oChrtO As ChartObject

 Dim lWidth As Long, lHeight As Long

 Set oWs = ActiveSheet

 Set oRng = oWs.Range(area)

 oRng.CopyPicture xlScreen, xlPicture

 lWidth = oRng.Width

 lHeight = oRng.Height

 Set oChrtO = oWs.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)

 oChrtO.Activate

 With oChrtO.Chart

  .Paste

  .Export Filename:=foto, Filtername:="JPG"

 End With

 oChrtO.Delete

End Function

Sub test()

    foto = "d:\Foto" & ".jpeg"

    area = "A107:E117"

    A = SavePicToFile(foto, area)

End Sub

edit connection OLEDBconnection / Last day of month

 

Sub RenameConnections()

Dim conn As WorkbookConnection

Dim ole As OLEDBConnection

For Each conn In ThisWorkbook.Connections

    If conn.Name = "Connection1" Then

        Set ole = conn.OLEDBConnection

        Sheets("Sheet1").Range("A1:A5").Clear

        Sheets("Sheet1").Cells(1, 1) = ole.CommandText

        'Sheets("Sheet1").Cells(1, 1) = Sheets("Sheet1").Cells(38, 1)

        len_be = InStr(1, UCase(Sheets("Sheet1").Cells(1, 1)), "BETWEEN")

        Sheets("Sheet1").Cells(2, 1) = Mid(Sheets("Sheet1").Cells(1, 1), 1, len_be + 7)

        len_and1 = InStr(len_be + 7, UCase(Sheets("Sheet1").Cells(1, 1)), "AND")

        len_and1 = InStr(len_and1 + 3, UCase(Sheets("Sheet1").Cells(1, 1)), ") AND")

        Sheets("Sheet1").Cells(3, 1) = Mid(Cells(1, 1), len_and1)

        StartDate = Sheets("Sheet1").Cells(7, 5) & "/" & 1 & "/" & Sheets("Sheet1").Cells(7, 6)

        StopDate = Sheets("Sheet1").Cells(9, 5) & "/" & lastday(Sheets("Sheet1").Cells(9, 5), Sheets("Sheet1").Cells(9, 6)) & "/" & Sheets("Sheet1").Cells(9, 6)

        Sheets("Sheet1").Cells(4, 1) = Sheets("Sheet1").Cells(2, 1) & " '" & StartDate & "' and '" & StopDate & "'" & Sheets("Sheet1").Cells(3, 1)

        ole.CommandText = Sheets("Sheet1").Cells(4, 1)

        conn.Refresh

    End If

Next

End Sub

Function lastday(m, y)

d = 1

While IsDate(d & "/" & MonthName(CInt(m)) & "/" & CInt(y))

    d = d + 1

Wend

d = d - 1

lastday = d

End Function

Select folder and get list file in folder (VBA)

 Sub Button2_Click()

    Dim oFSO As Object

    Dim oFolder As Object

    Dim oFile As Object

    Dim i As Integer

    Dim FldrPicker As FileDialog

    Dim myFolder As String

    'Have User Select Folder to Save to with Dialog Box

    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker

        .Title = "Select A Target Folder"

        .AllowMultiSelect = False

    If .Show <> -1 Then Exit Sub 'Check if user clicked cancel button

        myFolder = .SelectedItems(1) & "\"

    End With

    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Set oFolder = oFSO.GetFolder(myFolder)

    For Each oFile In oFolder.Files

        Cells(i + 1, 1) = oFile.Name

        i = i + 1

    Next oFile

    

End Sub

Reverse vlookup , multi-condition sum

Reverse vlookup

 =INDEX(B:B,MATCH(TEXT(D9,"0"),D:D,0),0)

Text(xx,"0") convert number to text

MATCH(find_text,D:D,0) return index found

INDEX(B:B,index,0) return data follow index

Multi-condition sum

=SUMIFS(L:L,B:B,"FR",K:K,$B3)

SUMIFS(sum_column,condition1,find1,condition2,find2)

EXCEL EXPERT !!!!!!!!!!!! Function AGGREGATE

 AGGREGATE(function,option,Array,k)

AGGREGATE(function,option,ref1,ref2...)

 AGGREGATE(function,option,Area*Area=เงื่อนไข,ref)

=AGGREGATE(14,7,I:I*((J:J=2)),1)

14       Large

7         no error ...

I:I        พื้นที่ค้นหา

J:J=2   เงื่อนไข

1   not know

Clear Pivot cache in excel : paste it on thisworkbook and refresh connection

 Private Sub Workbook_Open()

    Dim xPt As PivotTable

    Dim xWs As Worksheet

    Dim xPc As PivotCache

    Application.ScreenUpdating = False

    ThisWorkbook.RefreshAll

    For Each xWs In ActiveWorkbook.Worksheets

        For Each xPt In xWs.PivotTables

            xPt.PivotCache.MissingItemsLimit = xlMissingItemsNone

        Next xPt

    Next xWs

    For Each xPc In ActiveWorkbook.PivotCaches

        On Error Resume Next

        xPc.Refresh

    Next xPc

    Application.ScreenUpdating = True

End Sub

Unlock protect sheet xlsx

1 rename xlsx to zip
> ren protect.xlsx protect.zip
2 In zip goto xl  --> worksheets
3 unzip sheetx.xml tofix it (outside zip)
4 open sheetx.xml and search "protect"
5 remove

example


6 put all remove protect back to zip
7 rename zip to xlsx

Finish

Cr.
http://www.excelsupersite.com

http://www.excelsupersite.com/how-to-remove-an-excel-spreadsheet-password-in-6-easy-steps/

Function แก้ไข date เพิ่ม0 และกำหนดรูปแบบ // Function select file and exec and insert to worksheet

Function Ndate(x, y, R)
A = Mid(x, 1, 2)
B = Mid(x, 4, 2)
R = R
newdate = DateAdd("d", 1, A & "-" & MonthName(B) & "-" & y)
A = Day(newdate)
If Len(A) = 1 Then
    A = "0" & A
End If
B = Month(newdate)
If Len(B) = 1 Then
    B = "0" & B
End If
    Ndate = A & "/" & B
End Function

Sub FileOpenDialogBox()

'Display a Dialog Box that allows to select a single file.
'The path for the file picked will be stored in fullpath variable
  With Application.FileDialog(msoFileDialogFilePicker)
        'Makes sure the user can select only one file
        .AllowMultiSelect = False
        'Filter to just the following types of files to narrow down selection options
        .Filters.Add "PDF Files", "*.pdf", 1
        'Show the dialog box
        .Show
       
        'Store in fullpath variable
        fullpath = .SelectedItems.Item(1)
    End With
   
    fullpath = """X:\Delivery Section\Test PDS_01\Print KB\pdftotext.exe""" + fullpath + " /to " + """X:\Delivery Section\Test PDS_01\Print KB\1.txt"""
    'fullpath = "X:\Delivery Section\Test PDS_01\Print KB\pdftotext.exe"
    'MsgBox fullpath
Shell fullpath, vbNormalFocus
    Dim wbI As Workbook, wbO As Workbook
    Dim wsI As Worksheet

    Set wbI = ThisWorkbook
    Set wsI = wbI.Sheets("PDF") '<~~ Sheet where you want to import

    Set wbO = Workbooks.Open("X:\Delivery Section\Test PDS_01\Print KB\1.txt")

    wbO.Sheets(1).Cells.Copy wsI.Cells



    wbO.Close SaveChanges:=False
End Sub

INDIRECT FUNCTION ใช้ในการเชื่อมชื่อชีทโดยอ้างอิงเซลได้

INDIRECT("'"&sheet&"'!"&name)

example

=countif(indirect(D$1&"!$A:$A"),$A2)

=countif(MUSCATEL!$A:$A,$A2)

REFERENCE SHEET NAME FROM CELL.VALUE

set row and column in cm

How to set cell size in cm (centimeters) in Excel?

On a worksheet, the default units for the row height and column width are preset, and the default column width is 8.38 characters and the default row height is 12.75 points. And in Excel, it is difficult for you to set the row height or column width in inches or centimeters. But, sometimes you need to change the height and width to centimeters for some purpose. How could you solve this problem?

Set cell size in cm (centimeters) with VBA code

Set cell size in cm (centimeters) with Kutools for Excel

Kutools for Excel: add 120 new features in Excel. Save one hour every day.
Classic Menu for Office: brings back classic menus to Office 2010 and 2013 (includes Office 365).
Office Tab: brings tabbed interface to Office as the use of web browser Chrome, Firefox and Internet Explorer.

---

Set cell size in cm (centimeters) with VBA code

Amazing! Using Tabs in Excel like Firefox, Chrome, Internet Explore 10!

You can’t set the height and width in centimeters with Excel’s functions, except for using VBA code. The below two codes can help you to set column width and row height. Do as follows:
1. Select the cells that you want to set them in centimeters.
2. Click Developer > Visual Basic, a new Microsoft Visual Basic for applications window will be displayed, click Insert > Module, and input the following code into the Module:
Code for setting row height in centimeters:

Sub RowHeightInCentimeters()
Dim cm As Single
cm = Application.InputBox("Enter Row Height in Centimeters", _
"Row Height (cm)", Type:=1)
If cm Then
Selection.RowHeight = Application.CentimetersToPoints(cm)
End If
End Sub

3. Then click  button to execute the code. And a prompt box will pop out to tell you to enter a number of row height. See screenshot:

Note: the number you enter must be less than 15. And this VBA code won't change row height if you enter 0 in this dialog box.
4. Click OK. And the row height of the selected cells have been set with 2 centimeters. See screenshot:
If you want to set the column width in centimeters as well, you can input the following code:
Code for setting column width in centimeters:

Sub ColumnWidthInCentimeters()
Dim cm As Single, points As Integer, savewidth As Integer
Dim lowerwidth As Integer, upwidth As Integer, curwidth As Integer
Dim Count As Integer
Application.ScreenUpdating = False
cm = Application.InputBox("Enter Column Width in Centimeters", _
"Column Width (cm)", Type:=1)
If cm = False Then Exit Sub
points = Application.CentimetersToPoints(cm)
savewidth = ActiveCell.ColumnWidth
ActiveCell.ColumnWidth = 255
If points > ActiveCell.Width Then
MsgBox "Width of " & cm & " is too large." & Chr(10) & _
"The maximum value is " & _
Format(ActiveCell.Width / 28.3464566929134, _
"0.00"), vbOKOnly + vbExclamation, "Width Error"
ActiveCell.ColumnWidth = savewidth
Exit Sub
End If
lowerwidth = 0
upwidth = 255
ActiveCell.ColumnWidth = 127.5
curwidth = ActiveCell.ColumnWidth
Count = 0
While (ActiveCell.Width <> points) And (Count < 20)
If ActiveCell.Width < points Then
lowerwidth = curwidth
Selection.ColumnWidth = (curwidth + upwidth) / 2
Else
upwidth = curwidth
Selection.ColumnWidth = (curwidth + lowerwidth) / 2
End If
curwidth = ActiveCell.ColumnWidth
Count = Count + 1
Wend
End Sub

---

Set cell size in cm (centimeters) with Kutools for Excel

With the above codes, you can only set cell size in centimeters, today, I will introduce you a multifunctional tool, Kutools for Excel which not only can set cell size in centimeters but also in inches, pound and pixels.
Kutools for Excel: with more than 120 handy Excel add-ins, free to try with no limitation in 30 days. Get it Now.
After installing Kutools for Excel, you can quickly set row height and column width with the following steps:
1.Highlight the cells that you want to set them in centimeters.
2. Click Kutools > Range Converter > Adjust Cell Size, see screenshot:

3. In the Adjust Cell Size dialog box, choose the Unit type you need and specify the Row height and Column width from Set values. See screenshot:

4. Then click OK or Apply. You will get cells with 2 cm row height and 3cm column width.

With this function, you can also set cell size in pound, inches and pixels. Click to know more about this feature.

---

Related articles:
Set column width and row height for a range
How to square multiple cells in Excel?

---

Kutools for Excel

More than 120 Advanced Functions for Excel 2013, 2010, 2007 and Office 365.