I'm writing a script that will automatically copy value from sheet FORM and paste to specific sheet that listed on a table of sheet CONFIG with specific column and range for the sheet name and the corresponding column on sheet FORM. However, everytime I turned on the script its cause Not responding, I have tried to change the value that must imported from CONFIG sheet to the real integer but the problem still there.
Sub importvalue()
Dim sheetname, sheetcolumn As String
Dim isheet, iform, output_idx, output_stt As Integer
Dim confsheet As Worksheet
Dim formsheet As Worksheet
Dim outputsheet As Worksheet
Set formsheet = ThisWorkbook.Worksheets("FORM")
Set confsheet = ThisWorkbook.Worksheets("CONFIG")
isheet = 2
Dim thoigian As String
thoigian = formsheet.Range("E1").Value & "-" & formsheet.Range("G1").Value
While isheet <= 5
confsheet.Range("E1").Value = isheet
sheetname = confsheet.Range("J" & isheet).Value
sheetcolumn = confsheet.Range("K" & isheet).Value
Set outputsheet = ThisWorkbook.Worksheets(sheetname)
iform = 2
output_idx = outputsheet.Range("A1").Value
output_stt = outputsheet.Range("C1").Value
outputsheet.Range("A" & output_idx).Value = thoigian
outputsheet.Range("B" & output_idx).Value = output_stt
While iform <= 115
confsheet.Range("E1").Value = iform
outputcolumn = confsheet.Range("D" & iform).Value
formrow = confsheet.Range("C" & iform).Value
If Not formrow = "" Then
outputsheet.Range(outputcolumn & output_idx).Value = formsheet.Range(sheetcolumn & formrow).Value
iform = iform + 1
End If
Wend
isheet = isheet + 1
Wend
End Sub
EDIT 1: This is the dropbox link the for sample that I'm working with: https://www.dropbox.com/s/cjf5xce20o2f0tl/SAMPLE.xlsm?dl=0
EDIT 2: Thank you #FunThomas and #FaneDuru for pointing out my problem.
Sub importvalue()
Dim sheetname, sheetcolumn As String
Dim isheet, iform, output_idx, output_stt As Integer
Dim confsheet As Worksheet
Dim formsheet As Worksheet
Dim outputsheet As Worksheet
Set formsheet = ThisWorkbook.Worksheets("FORM")
Set confsheet = ThisWorkbook.Worksheets("CONFIG")
isheet = 2
Dim thoigian As String
thoigian = formsheet.Range("E1").Value & "-" & formsheet.Range("G1").Value
While isheet <= 5
confsheet.Range("E1").Value = isheet
sheetname = confsheet.Range("J" & isheet).Value
sheetcolumn = confsheet.Range("K" & isheet).Value
Set outputsheet = ThisWorkbook.Worksheets(sheetname)
iform = 2
output_idx = outputsheet.Range("A1").Value
output_stt = outputsheet.Range("C1").Value
outputsheet.Range("A" & output_idx).Value = thoigian
outputsheet.Range("B" & output_idx).Value = output_stt
While iform <= 115
confsheet.Range("E1").Value = iform
outputcolumn = confsheet.Range("D" & iform).Value
formrow = confsheet.Range("C" & iform).Value
If Not formrow = "" Then
outputsheet.Range(outputcolumn & output_idx).Value = formsheet.Range(sheetcolumn & formrow).Value
End If
iform = iform + 1
Wend
isheet = isheet + 1
Wend
End Sub
Related
I've been trying to figure this out for past 2 days but I just can't find a proper solution.
Here's my code:
Private Sub Update()
Worksheets("PBF_Graphs").Activate
ThisWorkbook.Worksheets("PBF_Graphs").Unprotect Password:="test"
Dim lastRow As Range
Dim modelSheet As String
Dim currentModel As String
Dim boltNo As Integer
Dim boltRange As Range
Dim BSN_Range As Range
Dim chart As ChartObject
Dim wb As Workbook
Dim ws As Worksheet
Dim chartName As String
Dim graphNo As Integer
Dim chartNo As String
Dim ch As String
Dim i As Integer
Dim j As Integer
Dim currentFixing As String
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Set lastRow = Range("C2")
Set BSN_Range = Range("$C$2")
chartNo = "Chart "
Const fixing1 = "$G$1"
Const fixing2 = "$I$1"
Const fixing3 = "$K$1"
Const fixing4 = "$M$1"
currentFixing = "$G$1"
' set up bolt number as 1 for incrementation always start from FP-FB and finish a RP-RB
boltNo = 1
Set boltRange = Range("G2")
currentModel = MainMenu.globalModel
' set current model name
Select Case currentModel
Case "Model1"
modelSheet = "DP025"
graphNo = 3
j = 3
Case "Model2"
modelSheet = "DP025_2"
graphNo = 7
j = 7
Case "Model3"
modelSheet = "DP025_3"
graphNo = 11
j = 11
Case "Model4"
modelSheet = "DP025_4"
graphNo = 16
j = 16
End Select
For i = graphNo To graphNo + 3
' this will automatically change the chart
ws.ChartObjects(chartNo & j).Activate
ActiveChart.SeriesCollection(1).Select
Application.CutCopyMode = False
ActiveChart.SeriesCollection.NewSeries
ActiveChart.FullSeriesCollection(1).Name = modelSheet & currentFixing
ActiveChart.FullSeriesCollection(1).values = modelSheet & "!" & boltRange.End(xlDown) ' <- doesn't work gives 1004 error
' ActiveChart.FullSeriesCollection(1).values = modelSheet & "!" & "G2:G999" <- works but is not dynamic and if there are blanks it will show in chart
ActiveChart.FullSeriesCollection(1).XValues = modelSheet & BSN_Range.End(xlDown) ' <- doesn't work either
j = j + 1
incrementRange boltNo, boltRange, currentFixing
Next i
ThisWorkbook.Worksheets("PBF_Graphs").Protect Password:="test"
End Sub
Function incrementRange(ByVal bNumber As Integer, bRange As Range, cFixing As String)
bNumber = bNumber + 1
Select Case bNumber
Case 1
Set bRange = Range("$G$2")
cFixing = "$G$1"
Case 2
Set bRange = Range("$I$2")
cFixing = "$I$1"
Case 3
Set bRange = Range("$K$2")
cFixing = "$K$1"
Case 4
Set bRange = Range("$M$2")
cFixing = "$M$1"
End Select
End Function
I commented the part that doesn't work as I want to and what works as I don't want to. Basically the data provided for these charts change, so the range is not fixed and I need to update dynamically based on sample size.
Edit:
The boltRange Range is not working, giving the 1004 application-defined or object-defined error, where as a static string of for example "G2:G999" works, I need that boltRange.End(xlDown) which I want to change according to the required column and go down to the last value
As stated in comments
Changing the following in:
' this will automatically change the chart
ActiveChart.FullSeriesCollection(1).values = modelSheet & "!" & boltRange.End(xlDown) ' <- doesn't work gives 1004 error
' ActiveChart.FullSeriesCollection(1).values = modelSheet & "!" & "G2:G999" <- works but is not dynamic and if there are blanks it will show in chart
ActiveChart.FullSeriesCollection(1).XValues = modelSheet & BSN_Range.End(xlDown) ' <- doesn't work either
To the following:
' this will automatically change the chart
ActiveChart.FullSeriesCollection(1).values = modelSheet & "!" & boltRange.Address & ":" & _
Worksheets(modelSheet).Cells(Rows.Count, boltRange.Column).End(xlUp).Address
ActiveChart.FullSeriesCollection(1).XValues = modelSheet & "!" & BSN_Range.Address & ":" & _
Worksheets(modelSheet).Cells(Rows.Count, BSN_Range.Column).End(xlUp).Address
I have the following code that is intended to create a series of combo boxes on a worksheet. Since I cannot be in break mode when creating combo boxes I am struggling to find out what I am doing wrong.
Private Sub CreatePlayerSelectorComboBoxes()
Application.ScreenUpdating = True
Dim currStatusBarMgr As StatusBarManager
Set currStatusBarMgr = New StatusBarManager
currStatusBarMgr.MessagePrefix = "Creating Control: "
With MatchesTeamPlayersWS
.Range(.Cells(17, 1), .Cells(17, .UsedRange.Columns.Count)).ClearContents
Dim matchCounter As Long
For matchCounter = 1 To 6
Dim controlColumnMatch As Long
controlColumnMatch = ((matchCounter - 1) * 24)
Dim matchText As String
matchText = "M" & matchCounter
Dim teamCounter As Long
For teamCounter = 1 To 2
Dim controlColumnTeam As Long
controlColumnTeam = ((teamCounter - 1) * 12)
Dim teamText As String
Select Case teamCounter
Case Is = 1
teamText = "TmA"
Case Is = 2
teamText = "TmB"
End Select
Dim positionCounter As Long
For positionCounter = 1 To 4
Dim positionText As String
positionText = "P" & positionCounter
Dim controlText As String
controlText = matchText & teamText & positionText
Dim currDivAControlName As String
currDivAControlName = "DivA" & controlText
Dim currDivBControlName As String
currDivBControlName = "DivB" & controlText
Dim controlColumnPosition As Long
controlColumnPosition = 3 + ((positionCounter - 1) * 3)
Dim controlColumn As Long
controlColumn = controlColumnMatch + controlColumnTeam + controlColumnPosition
Dim controlCell As Range
Set controlCell = .Cells(17, controlColumn)
currStatusBarMgr.PostStatusBarUpdate (currDivAControlName)
Debug.Print currDivAControlName
Dim controlDivA As Variant
Set controlDivA = .OLEObjects.Add(ClassType:="Forms.ComboBox.1", _
Link:=False, _
DisplayAsIcon:=False, _
Left:=controlCell.Left, _
Top:=controlCell.Top, _
Width:=140, _
Height:=24)
controlDivA.Name = currDivAControlName
currStatusBarMgr.PostStatusBarUpdate (currDivBControlName)
Debug.Print currDivBControlName
Dim controlDivB As Variant
Set controlDivB = .OLEObjects.Add(ClassType:="Forms.ComboBox.1", _
Link:=False, _
DisplayAsIcon:=False, _
Left:=controlCell.Offset(0, 144).Left, _
Top:=controlCell.Offset(0, 144).Top, _
Width:=140, _
Height:=24)
controlDivB.Name = currDivBControlName
Next
Next
Next
End With
Application.ScreenUpdating = True
End Sub
If I comment out the parts that are intended to create the combo boxes the code runs. I have inspected the Set assignments and they appear to be syntactically correct. I have also made sure the names are unique.
I have let Excel run and run.. All I get is [running]... until I force-quit Excel.
I am working with cells in a column, which have to be split. Element 1 of the string is supposed to be posted separately from Element 2 of the same string, each on another Worksheet.
String "123 ABC" -> "123" in column C and "ABC" in column D
I am running into a Runtime-Error 9 "Index out of Range" if one of the cells I am checking only contains "123" or "ABC" but no both parts.
I tried to work around it in the way you see in my code below. Needless to say it does not work.
Could one of the more experienced Excel-Gurus help me out here?
Thank you in advance for your time!
Application.ScreenUpdating = False
Dim wbInput As Workbook, wbOutput As Workbook
Set wbOutput = ActiveWorkbook
Dim wsInput As Worksheet, wsOutput As Worksheet, wsMistakes As Worksheet
Set wsOutput = wbOutput.Worksheets("FehlerVorkommen")
Set wsMistakes = wbOutput.Worksheets("NichtZuweisbar")
Dim lRowInput As Long, lRowOutput As Long, lRowMistakes As Long
Dim Lieferant As Range
Dim InputFile As String, myElements() As String
lRowOutput = wsOutput.Range("A" & Rows.Count).End(xlUp).Row
wsOutput.Range("A2:G" & lRowOutput).Clear
wsMistakes.Range("A2:G500").Clear
InputFile = Application.GetOpenFilename()
If InputFile = "Falsch" Then
Exit Sub
End If
Set wbInput = Workbooks.Open(InputFile)
Set wsInput = wbInput.Worksheets("owssvr")
lRowInput = wsInput.Range("A" & Rows.Count).End(xlUp).Row
'Get all Information
For Each Lieferant In wsInput.Columns(1).Rows("2:" & lRowInput)
If wsInput.Columns(3).Rows(Lieferant.Row) <> vbNullString Then
myElements = Split(wsInput.Columns(3).Rows(Lieferant.Row).Value, " ", 2) 'A maximum of 2 String-Parts to avoid 4-5 splits whenever there is a GmbH or AG or whatever
If IsEmpty(myElements(1)) = True Then <<<<<<<<<ERROR HERE<<<<<<<<<<<
lRowMistakes = wsMistakes.Range("A" & Rows.Count).End(xlUp).Row
NextRow = lRowMistakes + 1
wsInput.Columns(1).Rows(Lieferant.Row).Copy Destination:=wsMistakes.Columns(1).Rows(NextRow)
NextRow = NextRow + 1
Else
If IsNumeric(wsInput.Columns(1).Rows(Lieferant.Row)) = True And wsInput.Columns(1).Rows(Lieferant.Row) <> vbNullString _
And IsNumeric(wsInput.Columns(2).Rows(Lieferant.Row)) = True And wsInput.Columns(2).Rows(Lieferant.Row) <> vbNullString Then
wsInput.Columns(1).Rows("2:" & lRowInput).Copy Destination:=wsOutput.Columns(1).Rows("2:" & lRowInput) 'Task Namen
wsInput.Columns(2).Rows("2:" & lRowInput).Copy Destination:=wsOutput.Columns(2).Rows("2:" & lRowInput) 'Bestellpositionen
wsOutput.Columns(3).Rows(Lieferant.Row).Value = myElements(0) 'ID
wsOutput.Columns(4).Rows(Lieferant.Row).Value = myElements(1) 'Name
wsInput.Columns(3).Rows("2:" & lRowInput).Copy Destination:=wsOutput.Columns(5).Rows("2:" & lRowInput) 'Fehlerarten
Else 'Get all wrong inputs on separate Sheet
lRowMistakes = wsMistakes.Range("A" & Rows.Count).End(xlUp).Row
NextRow = lRowMistakes + 1
wsInput.Columns(1).Rows(Lieferant.Row).Copy Destination:=wsMistakes.Columns(1).Rows(NextRow)
NextRow = NextRow + 1
End If
End If
Else 'Get all wrong input on separate Sheet
lRowMistakes = wsMistakes.Range("A" & Rows.Count).End(xlUp).Row
NextRow = lRowMistakes + 1
wsInput.Columns(1).Rows(Lieferant.Row).Copy Destination:=wsMistakes.Columns(1).Rows(NextRow)
NextRow = NextRow + 1
End If
Next Lieferant
wbInput.Close
This line doesn't do what you think it's doing:
If IsEmpty(myElements(1)) = True
First, specifying a limit for the Split function doesn't mean that you always get that many elements in the array. Second, IsEmpty tests to see if a Variant is type VT_EMPTY, not whether a String has a value (Split returns a strongly typed array).
Just test the UBound instead:
If UBound(myElements) > 0 Then
I'm building an master excel file that is designed to gather data from lots of other excel files that are stored in the business Dropbox files and place them in the 2nd sheet of the master file. I built a original version on my local computer and that worked perfectly (the path3 variable) but once I tried to convert it based on a changing file path (because each user will have a different path from their PC) I am getting the run time error. The formula defined by path2 is what I have been trying to use but even though the variable seems to be holding the right value (I tested it by having it write out the values) it doesn't seem to be able to move the data, throwing the above error and highlighting the "rngdest.Formula = Chr(61) & path2" line. I really don't have any idea what is causing this and I have spent several days trying different approaches but to no avail so any ideas, solutions or links to already solved (I have spent a long time searching but haven't found anything) would be very much appreciated.
I've included the whole of the code for completeness, I think I've removed most of the redundant code that I left in but there may be some still left. If you need any clarifications on the code please let me know. Thanks for any potential help
Private Sub CommandButton2_Click()
Dim counter As Integer
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim a As Integer
Dim z As Integer
Dim y As Integer
Dim p As Integer
Dim Names() As String
Dim Fix1() As String
Dim path3 As String
Dim path2 As String
Dim SheetName As String
Dim c As Range
Dim found As Range
Dim BookName As String
Dim var1 As String
Dim rngdest As Range
Dim rngsource As Range
Dim cell As String
Dim adjust As Integer
Dim adjust2 As Integer
Dim rngname As Range
Dim colNo As Integer
Dim fin As String
Dim fin2 As String
Dim fin3 As String
Dim comp As String
Dim teststring As String
Dim currentWb2 As Workbook
Set currentWb2 = ThisWorkbook
MsgBox "Excel will now update the sheet, please be patient as this can take a few minutes. You will be notified once it is complete"
ReDim Fix1(1 To 4)
Fix1(1) = "A-F"
Fix1(2) = "G-L"
Fix1(3) = "M-R"
Fix1(4) = "S-Z"
counter = 0
With ActiveSheet
i = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
ReDim Names(1 To i, 1 To 4)
With ActiveSheet
For k = 1 To 4
For a = 2 To i
Names(a, k) = Cells(a, k).Value
Next a
Next k
End With
SheetName = "Analysis"
BookName = "Outcomes Final.xlsm"
For p = 1 To 4
fin2 = Split(Cells(, p).Address, "$")(1)
With ActiveSheet
l = .Cells(.Rows.Count, fin2).End(xlUp).Row
End With
For z = 1 To l
counter = counter + 1
fin = Split(Cells(, counter).Address, "$")(1)
currentWb2.Sheets("Sheet2").Range("" & fin & "1") = Names(z, p)
For y = 1 To 34
adjust = y + 1
cell = "$B$" & y & ""
If z = 1 Then
Else
teststring = GetPath()
teststring = teststring & "\Clients\"
path3 = "'C:\Users\Lewis\Documents\Outcomes\Floating Support\Clients\" & Fix1(p) & "\" & Names(z, p) & "\[Outcomes Final.xlsm]Analysis'!" & cell & ""
path2 = teststring & Fix1(p) & "\" & Names(z, p) & "\Outcomes\[Outcomes Final.xlsm]Analysis'!" & cell & ""
End If
Set rngdest = currentWb2.Sheets("Sheet2").Range("" & fin & "" & adjust & "")
Set rngsource = Range("B" & y & "")
rngdest.Formula = Chr(61) & path2
Next y
Next z
Next p
currentWb2.Sheets("Sheet2").Columns(1).EntireColumn.Delete
currentWb2.Sheets("Sheet1").Range("A1:D35").Interior.ColorIndex = 0
For j = 1 To counter
fin3 = Split(Cells(, j).Address, "$")(1)
If currentWb2.Sheets("Sheet2").Range("" & fin3 & "35") = "1" Then
With currentWb2.Sheets("Sheet1").Range("A1:D35")
comp = currentWb2.Sheets("Sheet2").Range("" & fin3 & "1")
Set c = .Find(comp, LookIn:=xlValues)
If Not c Is Nothing Then
c.Interior.ColorIndex = 3
End If
End With
End If
Next j
MsgBox "The update is now complete, please click on sheet 2 to view the data. All clients in red have not been properly completed"
End Sub
I have been working in this project step by step. I can't understand why it is not copying the row string values from the "SheetName" used as argument being passed into this function(SheetName). The function can read a file and create a second file with checkboxes based on the number of column titles found in the first file, but the column titles are not being copied into the second file as captions for the checkboxes. Any help is appreciated.
Function CallFunction(SheetName As Variant) As Long
Dim text As String
Dim titles(200) As String ' Dim titles(200) As String ' Array
Dim nTitles As Integer
Dim wks As Worksheet
Dim myCaption As String
Dim NewBook As Workbook
PathName = Range("F22").Value
Filename = Range("F23").Value
ControlFile = ActiveWorkbook.Name
Workbooks.Open Filename:=PathName & "\" & Filename
Set wks = ActiveWorkbook.Worksheets(SheetName)
For i = 1 To 199
If Trim(wks.Cells(4, i).Value) = "" Then
nTitles = i - 1
Exit For
End If
titles(i - 1) = wks.Cells(4, i).Value
Next
i = 1
Workbooks.Add
Set NewBook = ActiveWorkbook
NewBook.SaveAs fileExported
Workbooks.Open (fileExported)
For Each cell In Range(Sheets(SheetName).Cells(4, 1), Sheets(SheetName).Cells(4, 1 + nTitles))
myCaption = Sheets(SheetName).Cells(4, i).Value
With Sheets(SheetName).checkBoxes.Add(cell.Left, _
cell.Top, cell.Width, cell.Height)
.Interior.ColorIndex = 12
.Caption = myCaption
.Characters.text = myCaption
.Border.Weight = xlThin
.Name = myCaption
End With
i = i + 1
Next
End Function
I found the answer to my own question I just forgot to add the answer here. Ok, here it is
' Save all Jira column titles into jTitles
If sj = True Or ji = True Then
For j = 1 To 199
If Trim(wks1.Cells(4, j).Value) = "" Then
titlesj = j - 1
Exit For
End If
jTitles(j - 1) = wks1.Cells(4, j).Value
Next
j = 1
' Add column titles as checkboxes
For j = 0 To titlesj
Sheet1.ListBox1.AddItem jTitles(j)
Sheet1.ListBox3.AddItem jTitles(j)
Next
wb1.Close
End If