Function getCellValue(LOC_, strFile , strSheet , strPath )
'파일을 여는 것 따로 해줘야 하는데, 열었다 닫았다 prcess 과부하가 걸릴 수 있으므로 주의
Dim strPath, strFile, strSheet, strRng, strRef, Result As String
strPath = PathName_
strFile = FileName_
strSheet = SheetName_
'strRng = Range(LOC_).Value
strRng = LOC_
strRef = "'" & strPath & "[" & strFile & "]" & strSheet & "'!" & strRng
'Debug.Print (strRef)
getCellValue = Range(strRef).Value
End Function
Sub SheetToText()
Dim streamWrite As New ADODB.Stream '// 쓰기 스트림 선언 Microsoft ADODB 6.1 (ActiveX) 참조 필수
Dim sText As Variant '// 파일 데이터 선언
'// 파일 쓰기
streamWrite.Type = adTypeText
streamWrite.Charset = "UTF-8"
streamWrite.Open
'// 첫줄에 넣을 메시지
streamWrite.WriteText "// 첫줄"
'//시트 데이터 읽는데 필요한 변수 선언
Dim rng As Range
Dim iRow As Long, iCol As Integer
Dim sTxt As String, sPath As String, deLimiter As String
Set rng = ActiveSheet.UsedRange
deLimiter = ", " '// 구분자 "," 입력 바꿔도 됨
For iRow = 1 To rng.Rows.Count '// 1행부터 마지막 행까지
For iCol = 1 To rng.Columns.Count '// 1열부터 오른쪽 최대 열까지
sTxt = sTxt & ActiveSheet.Cells(iRow, iCol).Value & deLimiter
Next iCol
streamWrite.WriteText (Left(sTxt, Len(sTxt) - 1) & vbLf)
sTxt = vbNullString
Next iRow
'// 스트림의 마지막 표시
streamWrite.SetEOS
'// 세이브
Call streamWrite.SaveToFile(Application.ActiveWorkbook.Path + "\" + ActiveSheet.Name + ".txt", adSaveCreateOverWrite) '//저장할 경로와 파일 이름은 필요에 따라 변경할 것
'// 스트림 클로즈
streamWrite.Close
End Sub'Microsoft ActiveX Data Objects 6.1 Library 참조 필요
Private Sub EuckrToUtf8NoBOM(a_sFrom, a_sTo)
Dim streamRead As New ADODB.Stream '// 읽을 데이터
Dim streamWrite As New ADODB.Stream '// 작성할 데이터
Dim sText As Variant '// 파일 데이터
'// 파일데이터
streamRead.Type = adTypeText
streamRead.Charset = "euc-kr" '여기에 한글형을 입력한다.
streamRead.Open
Call streamRead.LoadFromFile(a_sFrom)
'// 개행코드 CRLF를 LF로 변환
sText = streamRead.ReadText
sText = Replace(sText, vbCrLf, vbLf)
'// 파일쓰기
streamWrite.Type = adTypeText
streamWrite.Charset = "UTF-8"
streamWrite.Open
'// euc-kr 을 utf-8 데이터로 쓴다.
Call streamWrite.WriteText(sText)
'// 바이너리 모드로 쓴 데이터 시작 위치를 BOM분의 3바이트씩 민다.
streamWrite.Position = 0
streamWrite.Type = adTypeBinary
streamWrite.Position = 3
'// 3바이트 민 상태에서 데이터를 취득
sText = streamWrite.Read
'// 3바이트 민 위치를 원래대로 돌린다.
streamWrite.Position = 0
'// BOM이 제거된 데이터를 처음부터 다시 쓴다.
Call streamWrite.Write(sText)
'// 현시점의 말미를 끝으로, 직전에 쓴 3바이트를 데이터 대상외로 한다.
streamWrite.SetEOS
'// 저장
Call streamWrite.SaveToFile(a_sTo, adSaveCreateOverWrite)
'// 파일 닫기
streamRead.Close
streamWrite.Close
End Sub
Option Explicit
Sub Createtextfile()
Dim TF As Object
Dim TFT As Object
'만들기
Set TF = CreateObject("scripting.filesystemobject")
Set TFT = TF.Createtextfile(Application.ActiveWorkbook.Path + "\l10n.js")
'Debug.Print (Application.ActiveWorkbook.Path)
'내용넣기
TFT.WriteLine "this is just test file" & vbCr & "afs"
TFT.WriteLine "this is 2nd line of test file"
TFT.WriteLine ActiveSheet.Name
'닫기
TFT.Close
Set TF = Nothing
Set TFT = Nothing
End SubSub 모든시트내용지우기()
Dim WS_Count As Integer
Dim i As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop.
For i = 1 To WS_Count
' 여기에 원하는 코드를 넣는다. 열린 파일에 숨긴 시트가 있으면 에러날 때가 있음
Debug.Print ("시트 변경함 : " + ActiveWorkbook.Worksheets(i).name)
ActiveWorkbook.Worksheets(i).Select
Cells(1, 1).Select
'모든 셀 내용 삭제
Cells.Select
Selection.ClearContents
Next i
End Sub
Function checkColorTagVerify(str_)
' "Microsoft VBScript Regular Expressions 5.5" 를 선택하고 실행하여야한다
'검사할 문장
Dim sText As String
sText = str_
'태그 꺽쇄 갯수를 찾아서 나머지가 발생하면 에러로 간주
Dim charactercountA As Integer
Dim charactercountB As Integer
charactercountA = Len(str_) - Len(Replace(str_, "<", ""))
charactercountB = Len(str_) - Len(Replace(str_, ">", ""))
'Debug.Print (charactercountA)
'Debug.Print (charactercountB)
If charactercountA Mod 2 > 0 Then
sText = "#COLOR_TAG_ERROR"
End If
If charactercountB Mod 2 > 0 Then
sText = "#COLOR_TAG_ERROR"
End If
'혹시 모를 나머지 검사...
Dim find_ As Integer '시작 태그 깨짐으로 color= 만 남는 경우
Dim find2_ As Integer '끝 태그 깨짐으로 /color 만 남는 경우
Dim find3_ As Integer '시작태그는 있는데 끝 태그가 없는 경우,
Dim find4_ As Integer '시작태그는 있는데 끝 태그가 없는 경우의 반대
'Debug.Print (sText)
find3_ = InStr(sText, " 0 And find4_ = 0 Then
sText = "#COLOR_TAG_ERROR"
End If
If find4_ > 0 And find3_ = 0 Then
sText = "#COLOR_TAG_ERROR"
End If
'정규식 시작
Dim regEx
Set regEx = New RegExp
regEx.Pattern = "<[^>]+>" '--- html tag match를 위한 정규식
regEx.IgnoreCase = True
regEx.Global = True
sText = regEx.Replace(sText, "")
'Debug.Print sText
'정규식 끝
find_ = InStr(sText, "color=")
find2_ = InStr(sText, "/color")
If find_ > 0 Then
sText = "#COLOR_TAG_ERROR"
End If
If find2_ > 0 Then
sText = "#COLOR_TAG_ERROR"
End If
checkColorTagVerify = sText
End Function
 | |
Private Sub VBA_JSON_TEST()
Dim JSON_ As String
Dim Parse As Object
'json 소스
JSON_ = "{ ""data"": { ""translations"": [ { ""translatedText"": ""welcome."", ""detectedSourceLanguage"": ""ko"" } ] }}"
Set Parse = JSONConverter.ParseJson(JSON_)
'접근 방법
Debug.Print Parse("data")("translations")(1)("translatedText")
End SubFunction CNumAlp(va As Variant) As Variant '?換する??
Dim al As String
If IsNumeric(va) = True Then '?値だったら
al = Cells(1, va).Address(RowAbsolute:=False, ColumnAbsolute:=False) '$無しでAddress取得
CNumAlp = Left(al, Len(al) - 1)
Else 'アルファベットだったら
CNumAlp = Range(va & "1").Column '列番?を取得
End If
End Function
Sub MacroSaveValue()
With Application: .Calculation = 3: .ScreenUpdating = 0
On Error Resume Next: Dim w As Worksheet, v
For Each w In Sheets
v = w.UsedRange.Value: w.UsedRange = v
Next: Set w = Nothing: .Calculation = 1: End With
'MsgBox ("모든 시트의 내용을 Value(값)으로 저장 완료")
'MsgBox ("!저장할 때 수식을 잃어버리지 않도록 주의!")
End Sub
Sub Delete_Cols_WithOut()
Dim co As Long, I As Long
Dim join As String
co = ActiveSheet.Range("A1").CurrentRegion.Columns.Count '추가할 시트에 Cols count 를 알아옵니다
Debug.Print ("#시트이름 : " + ActiveSheet.NAME)
Debug.Print ("--컬럼 목록 시작")
For I = 0 To co
Cells(1, I + 1).Select
join = Selection.Offset(0, 0) ' 비교할셀값 좌표
Debug.Print (join)
Next
Debug.Print ("--컬럼 목록 끝")
Debug.Print ("--------------------------------")
Cells(1, 1).Select
For I = 0 To co
join = Selection.Offset(0, 0) ' 비교할셀값 좌표
'Debug.Print (join)
If join = "Key" Or join = "삭제할 시트명" Then
Debug.Print ("찾음 : +" + join)
Selection.Offset(0, 1).Select
Else
Debug.Print ("삭제함 : -" + join)
Selection.EntireColumn.Delete
End If
Next
End Sub
'1시트 1셀 클릭 초기화
Sub WorksheetLoop()
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
Debug.Print ("시트 변경함 : " + ActiveWorkbook.Worksheets(I).NAME)
ActiveWorkbook.Worksheets(I).Select
Cells(1, 1).Select
Next I
End Sub
'폰트 생성과 관련된 시트 삭제
Sub RemoveFontSheet()
Dim WS_Count As Integer
Dim I As Integer
Dim WS_Name As String
Dim WS_NameFindKey As String
WS_Count = ActiveWorkbook.Worksheets.Count
Dim TargetEtc As Worksheet
' 루프를 돌면서 대상을 찾는다.
WS_NameFindKey = "Etc"
For I = 1 To WS_Count
'시트 선택 후 초기화
ActiveWorkbook.Worksheets(I).Select
Cells(1, 1).Select
Debug.Print ("현재시트 : +" + ActiveWorkbook.Worksheets(I).NAME)
WS_Name = ActiveWorkbook.Worksheets(I).NAME
If WS_Name = WS_NameFindKey Then
Debug.Print ("시트 찾음 : +" + WS_Name)
Set TargetEtc = ActiveWorkbook.Worksheets(I)
End If
Next I
If TargetEtc Is Nothing Then
Else
TargetEtc.Delete
End If
End Sub
Sub 서식지우기()
Dim co As Long, I As Long
Dim ro As Long, J As Long
Dim join As String
co = ActiveSheet.Range("A1").CurrentRegion.Columns.Count '추가할 시트에 Cols count 를 알아옵니다
ro = ActiveSheet.Range("A1").CurrentRegion.rows.Count '추가할 시트에 Cols count 를 알아옵니다
Debug.Print (co)
Debug.Print (ro)
Cells(1, 1).Select 'A1 부터 시작
For I = 0 To co '진행
join = Selection.Offset(0, 0) ' 비교할셀값 좌표
Debug.Print (join) ' join 은 셀값
Selection.EntireColumn.ClearFormats
Selection.Offset(0, 1).Select
Next
For J = 0 To ro '진행
join = Selection.Offset(0, 0) ' 비교할셀값 좌표
Debug.Print (join) ' join 은 셀값
Selection.EntireRow.ClearFormats
Selection.Offset(1, 0).Select
Next
End Sub
Function requestHTTP()
Dim PostData As String
Dim T As String
'Web에서 가져오기, 에러 발생하면 참조모듈 확인 (Microsoft WinHttpRequest 가 참조되어야 함)
Dim httpRequest As New WinHttpRequest
'아래에 넘길 포스트 데이터를 적는다.
PostData = "postData=_postData"
With httpRequest
.Open "POST", "http://오픈할 Open API 주소"
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.Send PostData
.WaitForResponse: DoEvents
T = .ResponseText
End With
requestHTTP = T
End Function