I'm trying to imitate copying multiple sheets to a new workbook and this is fine if I literally use the sheet names in the array function.
However if I try to pass a string variable into the array I get a subscript out of range error.
The line of concern is:
Wb.Sheets(Array(SheetsArray)).Copy After:=RegionWb.Sheets(RegionWb.Sheets.count)
Please see my code below :
Sub CreateFiles()
Application.ScreenUpdating = False
Dim LastRow As Long
Dim WKC As String: WKC = Replace(DateValue(DateAdd("ww", -1, Now() - (Weekday(Now(), vbMonday) - 1))), "/", ".")
Dim FilePath As String: FilePath = "Z:\MI\Krishn\Retail"
Dim BuyerLastRow As Long
Dim Wb As Workbook: Set Wb = ActiveWorkbook
Dim RegionWb As Workbook
Dim RegionCount As Integer
Dim RegionCounter As Integer
Dim SheetsArray As String
With BuyerList
LastRow = .Range("G1048576").End(xlUp).Row
BuyerLastRow = .Range("A1048576").End(xlUp).Row
'Create WKC Dir
If Dir(FilePath & "\" & WKC, vbDirectory) = "" Then
MkDir FilePath & "\" & WKC
End If
'Create Create Files
If CountFiles(FilePath & "\" & WKC) = 0 Then
For i = 2 To LastRow
RegionCounter = 0
SheetsArray = ""
' Set RegionWb = Workbooks.Add
' 'wb.SaveAs FilePath & "\" & WKC & "\" & .Cells(i, 7).Value
' RegionWb.SaveAs FilePath & "\" & WKC & "\" & "WKC " & WKC & " - " & .Cells(i, 7).Value & ".xlsb", 50
For j = 2 To BuyerLastRow
RegionCount = Application.WorksheetFunction.CountIf(.Range("C:C"), .Cells(i, 7).Value)
If .Cells(i, 7).Value = .Cells(j, 3).Value Then
SheetsArray = SheetsArray & """" & .Cells(j, 2).Value & ""","
RegionCounter = RegionCounter + 1
If RegionCounter = RegionCount Then
Debug.Print Left(SheetsArray, Len(SheetsArray) - 1)
Set RegionWb = Workbooks.Add
RegionWb.SaveAs FilePath & "\" & WKC & "\" & "WKC " & WKC & " - " & .Cells(i, 7).Value & ".xlsb", 50
'Wb.Sheets(Array(Left(SheetsArray, Len(SheetsArray) - 1))).Copy After:=RegionWb.Sheets(RegionWb.Sheets.count)
SheetsArray = Left(SheetsArray, Len(SheetsArray) - 1)
Wb.Sheets(Array(SheetsArray)).Copy After:=RegionWb.Sheets(RegionWb.Sheets.count)
'Wb.Sheets(Array()).Copy After:=RegionWb.Sheets(RegionWb.Sheets.count)
RegionWb.Save
RegionWb.Close
Exit For
End If
' Wb.Sheets(Wb.Sheets("Buyer list").Range(Cells(j, 2).Address).Value).Copy After:=RegionWb.Sheets(RegionWb.Sheets.count)
End If
Next j
'
'
Next i
End If
End With
Application.ScreenUpdating = True
End Sub
You can split the string into an Array like this:
Wb.Sheets(Split(SheetsArray, ",")).Copy After:=RegionWb.Sheets(RegionWb.Sheets.Count)
As GSerg pointed out: You'll need to remove the quotes around the Worksheet names.
SheetsArray = SheetsArray & .Cells(j, 2).Value & ","
The backslash would be a safer delimiter that using a comma because Worksheet names can include a comma but not a backslash.
SheetsArray = SheetsArray & .Cells(j, 2).Value & "/"
Wb.Sheets(Split(SheetsArray, "/")).Copy After:=RegionWb.Sheets(RegionWb.Sheets.Count)
Related
We are not able to create a formula which will copy 200 rows of a column in a same order and paste it multiple times in the same column and in the same order.
Example: columns A1:A200 have names in a particular order and we want to repeat the same order in the same column for 3000 times.
What is the way to do it without manual dragging?
Multi-Stack a Range Vertically
Sub VMultiStackTEST()
Const SourceRangeAddress As String = "A1:A200"
Const DestinationFirstCellAddress As String = "A1"
Const StackCount As Long = 3000
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim srg As Range: Set srg = ws.Range(SourceRangeAddress)
Dim dfCell As Range: Set dfCell = ws.Range(DestinationFirstCellAddress)
VMultiStack srg, dfCell, StackCount
' or (instead) just e.g.:
'VMultiStack Range("A1:A200"), Range("A1"), 3000
End Sub
Sub VMultiStack( _
ByVal SourceRange As Range, _
ByVal DestinationFirstCell As Range, _
Optional ByVal StackCount As Long = 1)
Const ProcName As String = "VMultiStack"
On Error GoTo ClearError
Dim IsSuccess As Boolean
Dim sData As Variant
Dim srCount As Long
Dim cCount As Long
Dim sAddress As String
With SourceRange.Areas(1)
sAddress = .Address(0, 0)
srCount = .Rows.Count
cCount = .Columns.Count
If srCount + cCount = 2 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = .Value
Else
sData = .Value
End If
End With
Dim dData As Variant: ReDim dData(1 To srCount * StackCount, 1 To cCount)
Dim n As Long
Dim sr As Long
Dim dr As Long
Dim c As Long
For n = 1 To StackCount
For sr = 1 To srCount
dr = dr + 1
For c = 1 To cCount
dData(dr, c) = sData(sr, c)
Next c
Next sr
Next n
Dim dAddress As String
With DestinationFirstCell.Resize(, cCount)
With .Resize(dr)
.Value = dData
dAddress = .Address(0, 0)
End With
.Resize(.Worksheet.Rows.Count - .Row - dr + 1).Offset(dr).Clear
End With
IsSuccess = True
ProcExit:
If IsSuccess Then
MsgBox "Stacked '" & sAddress & "' " & StackCount & " times to '" _
& dAddress & "'.", _
vbInformation, ProcName
Else
If Len(sAddress) > 0 Then
MsgBox "Could not stack '" & sAddress & "' " & StackCount _
& " times. No action taken.", _
vbExclamation, ProcName
Else
MsgBox "The program failed.", vbCritical, ProcName
End If
End If
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
With Office 365, you can put this into a LET as follows:
=LET( a, A1:A200, mBy, 3000,
r, ROWS( a ),
s, r * mBy,
INDEX( a, MOD(SEQUENCE( s,,0 ),r) + 1 ) )
where a is the column of names and mBy is the multiple (3000).
If you want to simplify it:
= INDEX( A1:A200, MOD(SEQUENCE( ROWS(A1:A200) * 3000,,0 ),ROWS(A1:A200)) + 1 )
I'm trying to go through a list with two columns and replace some of the text in the second column. I want to search for values using wildcards in combination with a value inside a 2D Array.
I've a file with all Pokemon cards separated in different worksheets by the set they're in. There are two columns that are called "Name" and "German Name".
I created another worksheet that contains all cards and their corresponding name and German name. Out of that worksheet, I create a 2 dimensional Array. This works.
Then I've loops going on and inside that I've got this line of code.
Worksheets(table).Cells(otherI, 2).Value = Replace(Worksheets(table).Cells(otherI, 2).Value, " * " & allArray(i, 0) & " * ", " * " & allArray(i, 1) & " * ")
Somewhere there is the problem.
E.g. I've the entry "Bulbasaur Lv.5" in both columns and now I want to replace "Bulbasaur" in the second column with its German equivalent "Bisasam" but the "Lv.5" mustn't be touched.
The whole script.
Option Explicit
Sub firstMakro()
'Variables
Dim allSize As Integer
Dim allArray()
Dim allI As Integer
allI = 1
Dim otherSize As Integer
Dim otherI As Integer
otherI = 1
Dim i As Integer
Dim table As Integer
table = 2
'Create Array
allSize = WorksheetFunction.CountA(Worksheets("All_Pokemons").Columns(1))
ReDim allArray(allI To allSize, 1)
Do
allArray(allI, 0) = Worksheets("All_Pokemons").Cells(allI, 1).Value
allArray(allI, 1) = Worksheets("All_Pokemons").Cells(allI, 2).Value
allI = allI + 1
Loop Until allI > allSize
MsgBox ("Array created")
'Replace Entries
For i = LBound(allArray, 1) To UBound(allArray, 1)
MsgBox (allArray(i, 0))
otherSize = WorksheetFunction.CountA(Worksheets(table).Columns(1))
Do
Worksheets(table).Cells(otherI, 2).Value = Replace(Worksheets(table).Cells(otherI, 2).Value, " * " & allArray(i, 0) & " * ", " * " & allArray(i, 1) & " * ")
otherI = otherI + 1
Loop Until otherI > otherSize
otherI = 1
Next i
End Sub
Replace doesn't use, or in this case even need, wildcards. Use
Replace(Worksheets(table).Cells(otherI, 2).Value, allArray(i, 0), allArray(i, 1))
Range Replace
Range.Replace (Microsoft Docs)
Tested only on a small dataset (feedback on efficiency (speed) is appreciated).
It will replace each occurrence of an English name with the associated German name in the whole destination range.
Adjust the values in the constants section.
Option Explicit
Sub Germanize()
Const sName As String = "All_Pokemons"
Const sfRow As Long = 2 ' ??? First Row
Const seCol As String = "A" ' ENG
Const sgCol As String = "B" ' GER
Const dName As String = "Sheet2" ' ??? Worksheet Tab Name
Const dfRow As Long = 2 ' ??? First Row
Const deCol As String = "A" ' ENG
Const dgCol As String = "B" ' GER
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source (All)
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim serg As Range: Set serg = RefColumn(sws.Cells(sfRow, seCol)) ' ENG
If serg Is Nothing Then Exit Sub ' no data
Dim seData As Variant: seData = GetRange(serg) ' ENG
Dim sgrg As Range: Set sgrg = serg.EntireRow.Columns(sgCol) ' GER
Dim sgData As Variant: sgData = GetRange(sgrg) ' GER
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim derg As Range: Set derg = RefColumn(dws.Cells(dfRow, deCol)) ' ENG
If derg Is Nothing Then Exit Sub ' no data
Dim dgrg As Range: Set dgrg = derg.EntireRow.Columns(dgCol) ' GER
Application.ScreenUpdating = False
dgrg.Value = derg.Value ' write ENG column to GER column
Dim seValue As Variant
Dim r As Long
' Replace in GER column.
For r = 1 To UBound(seData, 1)
seValue = seData(r, 1)
If Not IsError(seValue) Then
If Len(seValue) > 0 Then
dgrg.Replace seValue, CStr(sgData(r, 1)), xlPart, , False
End If
End If
Next r
Application.ScreenUpdating = True
MsgBox "German pokemon names updated.", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefColumn"
On Error GoTo ClearError
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
Sub OpenFile()
Dim temp_fdr As String
Dim test_fdr As String
Dim model_selector As String
Dim path As String
Dim Keyword_range As Range
'--------------------------------------------------------복사 할 영역 선택 변수
Dim Cont_R, Mov_T, Mov_V, Open_V As String
Dim Cont_R_row, Mov_T_row, Mov_V_row, Open_V_row, Test_T_row As Integer
Dim Cont_R_col, Mov_T_col, Mov_V_col, Open_V_col, Test_T_col As Integer
Dim realDataStartRow As Integer
Dim realDataEndRow As Long
Dim t1Rng As Range
Dim t2Rng As Range
Dim t3Rng As Range
Dim t4Rng As Range
Dim t5rng As Range
Dim t1Arr, t2Arr, t3Arr, t4Arr, t5Arr
'------------------------------------------------------- 시험 폴더 지정을 위한 변수 선언
today_total = Format(Date, "yyyy-mm-dd")
today_year = Format(Year(Date), "0000")
today_month = Format(Month(Date), "00")
today_day = Format(Day(Date), "00")
Dim lastModifiedFdr As String
'-------------------------------------------------------- 그래프 오리지널 폴더 -------------------나중에 바꿀 path
Dim chtWorkbookPath As String
Dim chtWorkbook As Workbook
Dim chtSheet As Worksheet
chtWorkbookPath = ThisWorkbook.path
Debug.Print chtWorkbookPath
'Set chtWorkbook = "C:\Users\bjkwack\Desktop\실시간그래프도식화작업중\" & today_year & "-" & today_month & ".xlsm"
' Debug.Print chtWorkbook
'-------------------------------------------------------- 현재 시험폴더 찾아가기------------------------------
' lastModifiedFdr = Module2.lastModifiedFdr
'MsgBox lastModifiedFdr
If Len(lastModifiedFdr) = 0 Then
temp_fdr = "\\172.30.145.135\evr data\" & today_year & "-" & today_month & "\" & today_day & "\"
lastModifiedFdr = Module2.LastFolder(temp_fdr)
End If
test_fdr = "\\172.30.145.135\evr data\" & today_year & "-" & today_month & "\" & today_day & "\" & lastModifiedFdr & "\"
'MsgBox test_fdr
'-----------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------- 시험 파일 위치지정
On Error Resume Next
Application.DisplayAlerts = False
Workbooks.Open Filename:=test_fdr & "\" & today_total & ".xls", ReadOnly:=True
Application.DisplayAlerts = True
Debug.Print test_fdr
Debug.Print lastModifiedFdr
'Workbooks("" & today_total & ".xls").Sheets(1).Activate
With ActiveSheet.UsedRange '---------------------------------------------------------- s = 출력물에서 2월 데이터 영역
Set Keyword_range = .Find(What:="접촉저항", LookAt:=xlWhole) '--------------------- 접촉저항 행 열 요소 찾기
On Error Resume Next
'Cont_R_row = Keyword_range.Row
On Error Resume Next
Cont_R_col = Keyword_range.Column
Debug.Print Cont_R_col
Set Keyword_range = .Find(What:="동작시간(ms)", LookAt:=xlWhole) '--------------------- 동작시간 행 열 요소 찾기
On Error Resume Next
'Mov_T_row = Keyword_range.Row
On Error Resume Next
Mov_T_col = Keyword_range.Column
Debug.Print Mov_T_col
Set Keyword_range = .Find(What:="석방전압(V)", LookAt:=xlWhole) '--------------------- 개방전압 행 열 요소 찾기
On Error Resume Next
'Open_V_row = Keyword_range.Row
On Error Resume Next
Open_V_col = Keyword_range.Column + 1 '--------------------*** 실제 데이터 열 보다 한칸 +1 에 있음 ***********
Set Keyword_range = .Find(What:="흡인전압(V)", LookAt:=xlWhole) '--------------------- 동작전압 행 열 요소 찾기
On Error Resume Next
'Mov_V_row = Keyword_range.Row
On Error Resume Next
Mov_V_col = Keyword_range.Column + 1 '--------------------*** 실제 데이터 열 보다 한칸 +1 에 있음 ***********
Set Keyword_range = .Find(What:="시험시간", LookAt:=xlWhole) '--------------------- 시험시간 행 열 요소 찾기
'On Error Resume Next
Test_T_row = Keyword_range.Row
Test_T_col = Keyword_range.Column
Debug.Print Test_T_row
Debug.Print Test_T_col
realDataStartRow = .Cells(Test_T_row, Test_T_col).End(xlDown).Row
realDataEndRow = .Cells(Rows.Count, Test_T_col).End(xlUp).Row
Debug.Print realDataStartRow
Debug.Print realDataEndRow
Set t1Rng = .Range(Cells(realDataStartRow, Test_T_col), Cells(realDataEndRow, Test_T_col))
Set t2Rng = .Range(Cells(realDataStartRow, Cont_R_col), Cells(realDataEndRow, Cont_R_col))
Set t3Rng = .Range(Cells(realDataStartRow, Mov_T_col), Cells(realDataEndRow, Mov_T_col))
Set t4Rng = .Range(Cells(realDataStartRow, Mov_V_col), Cells(realDataEndRow, Mov_V_col))
Set t5rng = .Range(Cells(realDataStartRow, Open_V_col), Cells(realDataEndRow, Open_V_col))
Debug.Print t1Rng
t1Arr = t1Rng.Value
t2Arr = t2Rng.Value
t3Arr = t3Rng.Value
t4Arr = t4Rng.Value
t5Arr = t5rng.Value
Debug.Print t2Arr
Debug.Print t3Arr
.Range("ab5").Resize(UBound(t1Arr, 1)).Value = t1Arr
.Range("ac5").Resize(UBound(t2Arr, 1)).Value = t2Arr
.Range("ad5").Resize(UBound(t3Arr, 1)).Value = t3Arr
.Range("ae5").Resize(UBound(t4Arr, 1)).Value = t4Arr
.Range("af5").Resize(UBound(t5Arr, 1)).Value = t5Arr
End With
' Selection.NumberFormatLocal = "h:mm:ss;#"
End Sub
You can use Application.Transpose to copy values from a column into a row
Dim rng As Range
'set the source range
Set rng = Range("A1:A5")
'copy to a column
Range("C1").Resize(rng.Rows.Count, 1).Value = rng.Value
'copy to a row
Range("E1").Resize(1, rng.Rows.Count).Value = Application.Transpose(rng.Value)
Note there's an upper limit to the size of the array you can transpose (~65k items I think)
I've made two different scripts in VBA to count the frequency of words contained in a CSV. Both scripts run fine, but I get different numbers for each word and I don't know why. Here are some of the steps that lead to the moment when the difference appears
Script 1:
Sub Dict_Array_1()
Dim Wb As Workbook, Wb1 As Workbook
Dim Ws As Worksheet, Ws1 As Worksheet
Dim Fd As Office.FileDialog
Dim StrFile As String
Dim i As Long, a As Long, LastR As Long
Dim Arr() As Variant
Dim Ban_() As String, T As String
Dim Ban As Object, Dict As Object
Dim Carac As Variant, w As Variant, Key As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
Set Wb = ActiveWorkbook
Set Ws = Wb.ActiveSheet
'---------- CSV ---------------------------------------------------------------------------------------------------------------
Set Fd = Application.FileDialog(msoFileDialogFilePicker)
With Fd
.AllowMultiSelect = False
.Title = "Select doc"
.Filters.Clear
.Filters.Add "Doc CSV (*.csv)", "*.csv"
If .Show Then
On Error GoTo ErrOpen 'ignore this
Set Wb1 = Workbooks.Open(.SelectedItems(1), ReadOnly:=True, Local:=False)
On Error GoTo 0
Set Ws1 = Wb1.Sheets(1)
With Ws1
LastR = .Cells(.Rows.Count, "S").End(xlUp).Row
Arr = .Range(Cells(1, 19), Cells(LastR, 19)).Value2
End With
Wb1.Close 0
Set Wb1 = Nothing
Set Ws1 = Nothing
Else
Exit Sub
End If
End With
'---------------------------------------- COUNT ----------------------------------------------------------------------------------------------------
'Array with words i want to ban
Ban_ = Split("word1,word2,word3,etc", ",")
'Array with caract i want to ban
Carac = Array(".", ",", ";", ":", "!", "#", "$", "%", "&", "(", ")", "- ", "_", "--", "+", _
"=", "~", "/", "\", "{", "}", "[", "]", """", "?", "*", ">>", "»", "«")
Set Ban = CreateObject("Scripting.Dictionary") 'need late binding
Ban.CompareMode = vbTextCompare 'case insensitive
For i = 0 To UBound(Ban_)
Ban.Add Ban_(i), 1
Next i
Erase Ban_
'Dict to count words
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare 'case insensitive
For a = 1 To UBound(Arr, 1)
If Not IsError(Arr(a, 1))
T = Arr(a, 1)
For i = 0 To UBound(Carac)
T = Replace(T, Carac(i), "", , , vbTextCompare)
Next i
T = Application.Trim(T)
For Each w In Split(T, " ")
If Not Ban.exists(w) Then
If Not Dict.exists(w) Then
Dict.Add w, 1
Else
Dict.Item(w) = Dict.Item(w) + 1
End If
End If
Next w
End If
Next a
Exit Sub
Erase Arr
Erase Carac
Set Ban = Nothing
Script 2 is basically the same, only difference is that I access the .CSV in another way:
Sub Dict_ADODB()
Dim Wb As Workbook, Wb1 As Workbook
Dim Ws As Worksheet, Ws1 As Worksheet
Dim Fd As Office.FileDialog
Dim StrFile As String
Dim i As Long, a As Long, LastR As Long
Dim Arr() As Variant
Dim Ban_() As String, T As String
Dim Ban As Object, Dict As Object
Dim Carac As Variant, w As Variant, Key As Variant
Dim ObjC As Object, ObjR As Object 'Object Connection / Object Recordset
Const adOpenStatic = 3
Const adLockOptimistic = 3
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False
Set Wb = ActiveWorkbook
Set Ws = Wb.ActiveSheet
'---------- CSV ---------------------------------------------------------------------------------------------------------------
Set Fd = Application.FileDialog(msoFileDialogFilePicker)
With Fd
.AllowMultiSelect = False
.Title = "Select doc"
.Filters.Clear
.Filters.Add "Doc CSV (*.csv)", "*.csv"
If .Show Then
'----------- ADODB ---
Set ObjC = CreateObject("ADODB.Connection")
Set ObjR = CreateObject("ADODB.RecordSet")
On Error GoTo ErrOpen
ObjC.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & .InitialFileName & ";" & _
"Extended Properties=""text;HDR=YES;FMT=Delimited;CharacterSet=65001"""
On Error GoTo 0
'I just need one column
ObjR.Open "SELECT Message FROM " & Right(.SelectedItems(1), Len(.SelectedItems(1)) - InStrRev(.SelectedItems(1), "\")) & _
" WHERE Message IS NOT NULL", _
ObjC, adOpenStatic, adLockOptimistic
Arr = ObjR.GetRows()
ObjR.Close
ObjC.Close
Set ObjR = Nothing
Set ObjC = Nothing
Else
Exit Sub
End If
End With
'---------------------------------------- COUNT ----------------------------------------------------------------------------------------------------
'Array with word I don't need
Ban_ = Split("word1,word2", ",")
Carac = Array(".", ",", ";", ":", "!", "#", "$", "%", "&", "(", ")", "- ", "_", "--", "+", _
"=", "~", "/", "\", "{", "}", "[", "]", """", "?", "*", ">>", "»", "«")
Set Ban = CreateObject("Scripting.Dictionary")
Ban.CompareMode = vbTextCompare
For i = 0 To UBound(Ban_)
Ban.Add Ban_(i), 1
Next i
Erase Ban_
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare 'case insensitive
For a = 0 To UBound(Arr, 2)
If Not IsError(Arr(0, a)) Then
T = Arr(0, a)
For i = 0 To UBound(Carac)
T = Replace(T, Carac(i), "", , , vbTextCompare)
Next i
T = Application.Trim(T)
For Each w In Split(T, " ")
If Not Ban.exists(w) Then
If Not Dict.exists(w) Then
Dict.Add w, 1
Else
Dict.Item(w) = Dict.Item(w) + 1
End If
End If
Next w
End If
Next a
Erase Arr
Erase Carac
Set Ban = Nothing
Exit Sub
Here you go. When I do dict.count I do find that the total number of entries is different, which is only partly explained by the use of "WHERE Message IS NOT NULL". Any idea why would be greatly appreciated!
The best case to see what is happening is to write some log this line:
Dict.Add w, 1
E.g., if the values are up to 200, then write:
Dim cnt as long
Dict.Add w, 1
cnt = cnt + 1
Debug.Print cnt, w
If the values are above 200, then only the last 200 would be displayed on the immediate window, thus it will not help you a lot. You can build a String with the log and print the String in a Notepad exactly with the same.
Dim cnt as Long
Dim logString as String
Dict.Add w, 1
cnt = cnt + 1
logString = logString & VbCrLF & cnt, w
And at the end CreateLogFile logString:
Sub CreateLogFile(Optional strPrint As String)
Dim fs As Object
Dim obj_text As Object
Dim str_filename As String
Dim str_new_file As String
Dim str_shell As String
str_new_file = "\tests_info\"
str_filename = ThisWorkbook.Path & str_new_file
If Dir(ThisWorkbook.Path & str_new_file, vbDirectory) = vbNullString Then
MkDir ThisWorkbook.Path & str_new_file
End If
Set fs = CreateObject("Scripting.FileSystemObject")
Set obj_text = fs.CreateTextFile(str_filename & "\sometext.txt", True)
obj_text.writeline (strPrint)
obj_text.Close
str_shell = "C:\WINDOWS\notepad.exe "
str_shell = str_shell & str_filename & "\sometext.txt"
Shell str_shell
End Sub
Alright, using a Schema.ini seems to have fixed my issue. Something that is not clear in the documentation is that one should set "colX= Y Type" for each column in the CSV until the one he wants to select (at first I only set "Col19=Message" but it failed because the previous columns where not set...).
I'm sharing the relevant part of the code for anyone interested (Excel 2010 / X86 version):
Set fs = CreateObject("Scripting.FileSystemObject")
Set obj_text = fs.CreateTextFile(.InitialFileName & "\Schema.ini", True)
obj_text.write ("[" & Right(.SelectedItems(1), Len(.SelectedItems(1)) - InStrRev(.SelectedItems(1), "\")) & "]" & vbNewLine & _
"ColNameHeader=False" & vbNewLine & _
"CharacterSet=65001" & vbNewLine & _
"Format=CSVDelimited" & vbNewLine & _
"DecimalSymbol=." & vbNewLine & _
"Col1=1 Text" & vbNewLine & _
"Col2=2 Text" & vbNewLine & _
"Col3=3 Text" & vbNewLine & _
"Col4=4 Text" & vbNewLine & _
"Col5=5 Text" & vbNewLine & _
"Col6=6 Text" & vbNewLine & _
"Col7=7 Text" & vbNewLine & _
"Col8=8 Text" & vbNewLine & _
"Col9=9 Text" & vbNewLine & _
"Col10=10 Text" & vbNewLine & _
"Col11=11 Text" & vbNewLine & _
"Col12=12 Text" & vbNewLine & _
"Col13=13 Text" & vbNewLine & _
"Col14=14 Text" & vbNewLine & _
"Col15=15 Text" & vbNewLine & _
"Col16=16 Text" & vbNewLine & _
"Col17=17 Text" & vbNewLine & _
"Col18=18 Text" & vbNewLine & _
"Col19=GOODONE Memo") 'set all the previous cols until the one I need!
obj_text.Close
Set ObjC = CreateObject("ADODB.Connection")
Set ObjR = CreateObject("ADODB.RecordSet")
ObjC.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & .InitialFileName & ";" & _
"Extended Properties=""text;HDR=No;"""
ObjR.Open "SELECT GOODONE FROM " & Right(.SelectedItems(1), Len(.SelectedItems(1)) - InStrRev(.SelectedItems(1), "\")), _
ObjC, 0, 1
Arr = ObjR.GetRows()
A VBA-newby is in need of help.
I am trying to enable users of my Project to update their Excel-file from another, identical file. The data can include every type of data, including links.
However, I run into two Problems:
(1) When reaching a certain cell including a link to an external file, I get a Runtime Error 13: Type Mismatch.
(2) At some points in my table, the header gets copied down, in others not.
I am relatively new to VBA and don't know where my mistakes are. Any help to reach my Goal would be greatly appreciated!
Application.ScreenUpdating = False
Dim wbInput As Workbook
Dim wbOutput As Workbook
Set wbOutput = ActiveWorkbook
Dim wsOutputDB As Worksheet
Set wsOutputDB = wbOutput.Worksheets("Meta DB")
Dim wsOutputCriteria As Worksheet
Set wsOutputCriteria = wbOutput.Worksheets("Criteria")
Dim wsOutputSkills As Worksheet
Set wsOutputSkills = wbOutput.Worksheets("Supplier Skills")
Dim strInput As String
Dim ID As Range
Dim IDcolumn As Range
Dim FindID As Range
Dim FindChange
Dim lRowInput As Integer
Dim lRowOutput As Integer
Dim NextRow As Integer
Dim lastcol As Integer
Dim lastcolOutput As Integer
Dim HeaderColumn As Range
Dim FindNewColItem As Range
strInput = Application.GetOpenFilename()
Set wbInput = Workbooks.Open(strInput)
wbInput.Worksheets("Meta DB").Visible = True
lRowInput = wbInput.Worksheets("Meta DB").Range("D" & Rows.Count).End(xlUp).row
lRowOutput = wsOutputDB.Range("D" & Rows.Count).End(xlUp).row
NextRow = wsOutputDB.Range("D" & Rows.Count).End(xlUp).row + 1
'1.0. - - ######################Copy all missing DB-Entries####################
With wbInput.Worksheets("Meta DB")
lastcol = .Cells(3, Columns.Count).End(xlToLeft).Column
LastColLetter = Split(wbInput.Worksheets("Meta DB").Cells(3, lastcol).Address, "$")(1)
lastcolOutput = wsOutputDB.Cells(3, Columns.Count).End(xlToLeft).Column
'1.1. - - Check if any new Variables have been added
For Each HeaderColumn In .Range("B3:" & LastColLetter & "3")
Set FindNewColItem = wsOutputDB.Range("B3:" & LastColLetter & "3").Find(What:=HeaderColumn, LookAt:=xlWhole)
If FindNewColItem Is Nothing Then
NewColLetter = Split(HeaderColumn.Address, "$")(1)
NextCol = lastcolOutput + 1
wbInput.Worksheets("Meta DB").Range(NewColLetter & "3").Copy Destination:=wsOutputDB.Range(NewColLetter & "3")
NextCol = NextCol + 1
End If
Next HeaderColumn
'1.2. - - Check if there are any new Entries to the Database
For Each ID In .Range("D4:D" & lRowInput)
Set FindID = wsOutputDB.Range("D4:D" & lRowOutput).Find(What:=ID, LookIn:=xlValues, LookAt:=xlWhole)
'1.2.1. - - If ID is a new Entry, simply add it to our file, else...
If FindID Is Nothing Then
NewIDrow = Split(ID.Address, "$")(2)
wbInput.Worksheets("Meta DB").Range("B" & NewIDrow & ":" & LastColLetter & NewIDrow).Copy Destination:=wsOutputDB.Range("B" & NextRow & ":" & LastColLetter & NextRow)
NextRow = NextRow + 1
Else
'1.2.2. - - If ID already exists, check for Updates of any Information
For Each IDcolumn In .Range("B" & ID.row & ":" & LastColLetter & ID.row)
Set FindChange = wsOutputDB.Range("B" & FindID.row & ":" & LastColLetter & FindID.row).Find(What:=IDcolumn)
If FindChange Is Nothing Then
ColLetter = Split(IDcolumn.Address, "$")(1)
wbInput.Worksheets("Meta DB").Range(ColLetter & ID.row).Copy Destination:=wsOutputDB.Range(ColLetter & FindID.row)
End If
Next IDcolumn
End If
Next ID
End With