엑셀 메크로

Option Explicit
Private Declare Function SetCurrentDirectoryA Lib _
    "kernel32" (ByVal lpPathName As String) As Long

Sub ChDirNet(szPath As String)
    SetCurrentDirectoryA szPath
End Sub


Sub MergeSpecificWorkbooks()
    Dim MyPath As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim SaveDriveDir As String
    Dim fName As Variant


    ' Set application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    SaveDriveDir = CurDir
    ' Change this to the path\folder location of the files.
    ChDirNet "C:\Users\Ron\test"

    fName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                        MultiSelect:=True)
    If IsArray(fName) Then

        ' Add a new workbook with one sheet.
        Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
        rnum = 1


        ' Loop through all files in the myFiles array.
        For FNum = LBound(fName) To UBound(fName)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(fName(FNum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next
                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A1:C1")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If the source range uses all columns then
                    ' skip this file.
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        ' Copy the file name in column A.
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = fName(FNum)
                        End With

                        ' Set the destination range.
                        Set destrange = BaseWks.Range("B" & rnum)

                        ' Copy the values from the source range
                        ' to the destination range.
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value
                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next FNum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
    ChDirNet SaveDriveDir
End Sub
Sub 구구단_테이블()
    Dim x, y As Integer
    Dim i, j As Integer
    Dim fPath, fName As String
    Dim LR, NR As Long
    Dim wbGrab As Workbook
    Dim wsDest As Worksheet
    Dim sourceRange As Range
    
    '파일 읽어드리기
    Set wsDest = ThisWorkbook.Sheets("Summary")
    NR = 1
    
    fPath = "C:\Group\"
    fName = Dir(fPath & "38W.xls*")
    
    Do While Len(fName) > 0
        Set wbGrab = Workbooks.Open(fPath & fName)
        With wbGrab.Worksheets("shizhong") 'find sheet
            Set sourceRange = .Range("A2:E2")
        End With
        
        LR = Range("A" & Rows.Count).End(xlUp).Row 'how many rows of Info?
        
        If LR > 1 Then
            Range("A2:E" & LR).Copy wsDest.Range("A" & NR) 'B2번서부터 시작
            NR = wsDest.Range("B" & Rows.Count).End(xlUp).Row + 1 '마지막 + 1 줄
        End If
        wbGrab.Close False
        fName = Dir
    Loop
        
    
    x = Range("A1")
    y = Range("B1")
    
    For i = 2 To 9
        For j = 1 To 9
            Cells(Range("A1").Value + j + 1, Range("B1").Value + i - 1) = i & " X " & j & " = " & i * j
            If i = j Then
            Cells(Range("A1").Value + j + 1, Range("B1").Value + i - 1) = ""
            End If
        Next j
    Next i

    Columns("A:H").AutoFit
    Cells.Item(x, y).Select

End Sub
Sub ImportGroups()

Dim i, j As Integer
Dim fPath, fName As String
Dim LR As Long
Dim NR As Long
Dim wbGRP As Workbook
Dim wsDest As Worksheet
Dim sourceRange As Range

Set wsDest = ThisWorkbook.Sheets("Summary")
NR = 1 'wsDEST.Range("B" & Rows.Count).End(xlUp).Row + 1 'initial row setting

fPath = "C:\Group\"       'remember the final \ in this string

fName = Dir(fPath & "38W.xls*")        'get the first filename in fpath

Do While Len(fName) > 0
    Set wbGRP = Workbooks.Open(fPath & fName)   'open the file
    
    With wbGRP.Worksheets("shizhong") 'find sheet
        Set sourceRange = .Range("A2:E2")
    End With
    
    LR = Range("A" & Rows.Count).End(xlUp).Row  'how many rows of info?
    
    If LR > 1 Then
        'wsDEST.Range("A" & NR) = Replace(Range("A1"), "Group ", "")
        Range("A2:E" & LR).Copy wsDest.Range("A" & NR) 'B2번서부터 시작
        NR = wsDest.Range("B" & Rows.Count).End(xlUp).Row + 1 '마지막 +1줄
    End If
    
    wbGRP.Close False   'close data workbook
        fName = Dir         'get the next filename
Loop
'r1c1 표기법 row/column 표기법
'With Range("A5:A" & NR - 1)
'    .FormulaR1C1 = "=R[-1]C"
'    .Value = .Value
'End With

End Sub
Sub find_by_date()

Range("$A$2:$D$11").AutoFilter Field:=1, Criteria1:=Range("c15"), Operator:=xlAnd

'Sheets("sheet1").PageSetup.PrintArea = "$A$2:$D$13"

End Sub
Sub aa()
Range("$A:$A").Find What:="one"
End Sub

Sub aa1()
For j = 1 To 8
    Set i = Cells(j, 2).Find(Cells(1, 1))
'fkdlstnrj'
        Cells(j, 3) = "없음"
        If Not i Is Nothing Then
            Cells(j, 3) = "있음"
        End If
    Next j

Range("$A$1:$D$11").AutoFilter Field:=1, Criteria1:=Range("C15"), Operator:=xlAnd
     (표범위의. 첫번째열에서, C15번셀값과 동일한 값을 필터)

Sheets("sheet1").PageSetup.PrintArea = "$A$1:$D$13"
      (시트1. 인쇄영역을 A1~D14으로 지정)

End Sub

Sub Data_Gathering()
'
' Data_Gathering Macro
' 디렉토리의 모든 화일/시트를 검색, 해당날짜 데이타 모두 가져오기
'
Dim sht As Worksheet        '검색대상 시트
Dim oB As String            'original book  취합 워크북 이름
Dim oS As String            'original sheet 취합 워크시트 이름
Dim lb As Integer           'line of workbook (현재 화일의 출력 시작 행)
Dim ls As Integer           'line of sheet    (현재 시트의 출력 시작 행)
Dim shtname As String       '검색 시트 이름
Dim DtDir As String         'data directory 지정 디렉토리 주소
Dim dtFile As String        'data file      화일명
Dim irow As Integer         '기준문자열 행 번호
Dim icol As Integer         '기준문자열 열 번호
Dim itotal As Integer       '찾은 데이타 행 수
Dim isht As Integer         '현재 시트에서 찾은 데이타 수
Dim ibook As Integer        '현재 화일에서 찾은 데이타 수
Dim tsht As Integer         '데이타가 검색된 시트 수
Dim tbook As Integer        '데이타가 검색된 화일 수
Dim colnum As Integer       '검색문자열로부터 오른쪽으로 데이타 가져올 열 수
Dim Tdata As Variant        '검색문자열
Dim rngcell As Range        '검색범위
Tdata = ActiveCell.Value
irow = ActiveCell.Rows(1).Row
icol = ActiveCell.Columns(1).Column
ls = irow + 2
lb = irow + 2
DtDir = Cells(1, 1)
colnum = Cells(1, 4)
oB = ActiveWorkbook.Name
oS = ActiveSheet.Name
dtFile = Dir(DtDir & "*.xls*")
If dtFile = "" Then
    MsgBox "no excel file in " & DtDir
    Exit Sub
End If
Do
Workbooks.Open DtDir & dtFile
    ibook = 0
    For Each sht In Worksheets
        sht.Activate
        isht = 0
        ActiveSheet.UsedRange.Select
            For Each rngcell In Selection
                If Tdata = rngcell.Value Then
                    chk = 0
                    For i = 1 To colnum
                        With rngcell
                        If .Offset(0, i) <> "" Then chk = 1
                        End With
                    Next i
                    If chk = 1 Then
                        j = 0
                        Do
                            For i = 1 To colnum
                                With rngcell
                                    k = icol + i + 1
                                    Workbooks(oB).Worksheets(oS).Cells(ls + isht, k) = .Offset(0 + j, i)
                                End With
                            Next i
                            isht = isht + 1
                            ibook = ibook + 1
                            itotal = itotal + 1
                            
                            j = j + 1
                            chk = 0
                            With rngcell
                                If .Offset(0 + j, 0) = "" Then
                                    For k = 1 To colnum
                                        If .Offset(0 + j, k) <> "" Then chk = 1
                                    Next k
                                End If
                            End With
                            
                        Loop While chk = 1
                    End If
                End If
            Next rngcell
            
            If isht > 0 Then
                shtname = ActiveSheet.Name
                Workbooks(oB).Worksheets(oS).Activate
                Cells(ls, icol + 1) = shtname
                Range(Cells(ls, icol + 1), Cells(ls + isht - 1, icol + 1 + colnum)).Select
                GoSub Border_Line
                Range(Cells(ls, icol + 1), Cells(ls + isht - 1, icol + 1)).Select
                GoSub Cell_Merge
                ls = ls + isht
                tsht = tsht + 1
                sht.Activate
            End If
    
    Next sht
    
    If ibook > 0 Then
        shtname = ActiveWorkbook.Name
        Workbooks(oB).Worksheets(oS).Activate
        Cells(lb, icol) = shtname
        Range(Cells(lb, icol), Cells(lb + ibook - 1, icol)).Select
        GoSub Border_Line
        GoSub Cell_Merge
        lb = lb + ibook
        tbook = tbook + 1
        Workbooks.Open DtDir & dtFile
    End If
ActiveWorkbook.Close
dtFile = Dir()
Loop Until dtFile = ""
Workbooks(oB).Worksheets(oS).Activate
MsgBox tbook & "파일, " & tsht & "시트에서" & itotal & "개의 행을 찾았습니다"
Exit Sub
'괘선그리기 서브루틴
Border_Line:
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Return
    
'셀 병합 서브루틴
Cell_Merge:
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Return
End Sub