Visual Basic Excel Macro MessageBox.Show Throws "Object Required" Error - excel

Simply put no matter how hard I try I cannot get a MessageBox to appear through my Excel macro.
Here is the line I have so far:
MyBox = MessageBox.Show("Stuff", "Title")
When I run this macro I get the following error:
Run-time error '424':
Object required
What's going on!?!?
Here is the complete code:
Sub ImportParser()
'
' ImportParser Macro
' By: Dennis Plotnik (July 2013)
'
Dim ToKeepSize As Integer ' Size of ToKeep array
Dim BlankCount As Integer ' Counts blank lines so as to stop execution after EOF
Dim ReqText As String ' Required String
ReqText = "Import Control"
BlankCount = 0
ToKeepSize = -1
' Dim ToKeep As String()
Dim ToKeep() As String ' Array to store names of tables that include required text
Dim CurrentTable As String ' String to store last required table name
Range("B1").Select
Do
Do ' Go down until come to non-blank row (or exit if all blank)
Selection.Offset(1, 0).Select
Dim tempS As String
tempS = "'" + ActiveCell.Formula
ActiveCell.Value = tempS
If ActiveCell.Value = "" Then
BlankCount = BlankCount + 1
Else
Exit Do
End If
Loop Until BlankCount > 15
If InStr(1, ActiveCell.Value, ReqText, vbTextCompare) > 0 Then ' Check for ReqText in current cell
' ActiveCell.Value = "HELLO!" ' For DEBUG purposes
ToKeepSize = ToKeepSize + 1 ' Increment size of array (to allow for new value)
ReDim Preserve ToKeep(ToKeepSize)
Selection.Offset(0, -1).Select ' Move left to retrieve name of table (category)
CurrentTable = ActiveCell.Value
ToKeep(ToKeepSize) = CurrentTable
For j = 0 To 10000
Selection.Offset(1, 0).Select ' Cycle down until new table is reached
Do
If ActiveCell.Value = "" Then
BlankCount = BlankCount + 1
Selection.Offset(1, 0).Select
Else
Exit Do
End If
Loop Until BlankCount > 15
If ActiveCell.Value <> CurrentTable Then
Selection.Offset(-1, 1).Select ' Return to Field Name to continue search for ReqText
Exit For
End If
Next j
End If
Loop Until BlankCount > 15
' Range("F1").Select ' Print found tables [FOR DEBUG]
' For i = 0 To ToKeepSize
' ActiveCell.Value = ToKeep(i)
' Selection.Offset(1, 0).Select
' Next i
' ActiveCell.Value = CStr(ToKeepSize)
For i = 0 To 1 ' Prepare Table for Flag Columns
Range("A1").EntireColumn.Insert
Next i
Range("A1").Select
ActiveCell.Value = "Import Controlled?"
Range("B1").Select
ActiveCell.Value = "Delete it?"
Columns("A:F").AutoFit
BlankCount = 0
Dim ImportControl As Boolean
ImportControl = False
Range("C1").Select
Do ' Flag necessary columns
Selection.Offset(1, 0).Select
If ActiveCell.Value = "" Then
BlankCount = BlankCount + 1
Else
For i = 0 To ToKeepSize
If ActiveCell.Value = ToKeep(i) Then
Selection.Offset(0, -2).Value = 1
Exit For
End If
Next i
End If
Loop Until BlankCount > 15
Range("A1").Select ' Sort to push all required tables to top of file
Columns("A:A").Select
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A:F")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Do
Selection.Offset(1, 0).Select
Loop Until ActiveCell.Value = ""
MyBox = MessageBox.Show("Stuff", "Title")
Dim file As String
file = Application.ActiveWorkbook.Path
Dim Word As Object: Set Word = CreateObject("Word.Application")
Word.Visible = True
Set docWD = Word.Documents.Add
docWD.SaveAs file & "\" & "dictionary", FileFormat:=wdFormatDocument
Range(ActiveCell.Offset(0, 2), "F1").Copy
Word.Selection.Paste
End Sub

MessageBox.Show is VB.Net. Even though you have tagged it as VB.Net, I believe you are doing this in VBA.
Try this
MyBox = MsgBox("Stuff", vbInformation, "Title")

Related

Microsoft VBA Error - Run time Error - 1004

Run-time error '1004': The PivotTable field name is not valid. To create a PivotTable report you must use data that is organized as a list of labeled columns. If you are changing the name of a PivotTable field, you must type a new name for the field.
Here Is my Code?
Please tell me the mistake so I can understand it. also How Can I Correct it?
Option Explicit
Public PageName, RowName, ColumnName, DataName As String
Sub ShowForms()
frmGenerateReports.Show
End Sub
Sub CreatePivot()
Dim Destination, RangeData As Range
Set Destination = Worksheets("Reports").Range("A1")
Set RangeData = Range("A1", Range("I1").End(xlDown))
ActiveWorkbook.PivotCaches.Create _
(SourceType:=xlDatabase, SourceData:=RangeData) _
.CreatePivotTable TableDestination:=Destination, TableName:="SalesPivot"
End Sub
Sub SetFields()
Dim PvtTable As PivotTable
Set PvtTable = Worksheets("Reports").PivotTables("SalesPivot")
With PvtTable
.PivotFields(PageName).Orientation = xlPageField
.PivotFields(RowName).Orientation = xlRowField
.PivotFields(ColumnName).Orientation = xlColumnField
.PivotFields(DataName).Orientation = xlDataField
End With
ActiveWorkbook.Sheets("Reports").Activate
If frmGenerateReports.Sales <> "Model" Then
PvtTable.PivotSelect "", xlDataOnly
Selection.NumberFormat = "$#, ##0"
End If
Range("E1").Select
End Sub
Sub ConsolidateData(ThisMonth)
Dim BeenThere As Boolean
Dim Compare As String
Dim Sheet As Worksheet
BeenThere = False
Sheets.Add
ActiveSheet.Name = "Reports"
If frmGenerateReports.Period = "Month" Then
Select Case ThisMonth
Case "Jan"
ThisMonth = 1
Case "Feb"
ThisMonth = 2
Case "Mar"
ThisMonth = 3
Case "Apr"
ThisMonth = 4
Case "May"
ThisMonth = 5
Case "Jun"
ThisMonth = 6
Case "Jul"
ThisMonth = 7
Case "Aug"
ThisMonth = 8
Case "Sep"
ThisMonth = 9
Case "Oct"
ThisMonth = 10
Case "Nov"
ThisMonth = 11
Case "Dec"
ThisMonth = 12
End Select
End If
Select Case frmGenerateReports.Period
Case "Month"
For Each Sheet In Worksheets
Sheet.Select
Compare = ActiveSheet.Name
On Error Resume Next
Compare = Month(CDate(Compare))
If Compare = ThisMonth Then
frmGenerateReports.StartDate = Sheet.Name
If BeenThere = False Then
GrabCells 1
BeenThere = True
Else
GrabCells 2
DoEvents
End If
End If
Next
Case "All"
GrabCells 1
Do
frmGenerateReports.StartDate = frmGenerateReports.StartDate + 1
GrabCells 2
DoEvents
Loop Until frmGenerateReports.StartDate = frmGenerateReports.EndDate
Columns("A:J").EntireColumn.AutoFit
Range("A1").Select
Case "Other"
GrabCells 1
Do
frmGenerateReports.StartDate = frmGenerateReports.StartDate + 1
GrabCells 2
DoEvents
Loop Until frmGenerateReports.StartDate = frmGenerateReports.EndDate
Columns("A:J").EntireColumn.AutoFit
Range("A1").Select
End Select
End Sub
Sub GrabCells(StartingCell)
Dim CallDate, Where, Where2 As String
CallDate = Format(frmGenerateReports.StartDate, "d-mmm-yy")
Sheets(CallDate).Select
If Range("A2").Value <> Empty Then
Where = "B" & StartingCell
Where2 = "J" & StartingCell
Range(Where, Range(Where2).End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Range("A1").Select
Sheets("Reports").Select
ActiveSheet.Paste
Range("A1").End(xlDown).Offset(1).Select
Else
If StartingCell = 1 Then
Application.CutCopyMode = False
Range("B1:J1").Select
Selection.Copy
Sheets("Reports").Select
ActiveSheet.Paste
Range("A2").Select
End If
End If
End Sub
Sub FinishReport()
Dim Sheet As Worksheet
Workbooks.Open Filename:=ThisWorkbook.Path & "\Reports.xlsx"
For Each Sheet In Worksheets
Sheet.Select
Cells.Select
Selection.Clear
Range("A1").Select
Next
Workbooks("Sales - Fiscal Year1.xlsm").Activate
Sheets("Reports").Select
Cells.Select
Selection.Copy
Workbooks("Reports.xlsx").Activate
ActiveSheet.Paste
Range("A1").Select
Windows("Sales - Fiscal Year1.xlsm").Activate
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.Delete
Workbooks("Reports.xlsx").Activate
CreatePivot
SetFields
End Sub
I need to understand the logic behind the solution and why it caused?
So that I can prevent it from happening next time.

When a number is in the cell, count it in a column that matches column header

I'm currently trying to work on a macro that will look for grades and count assignments done. It works...for the most part...But I'm having some trouble with it being very static. I've hardcoded a specific range, but I need it to be dynamic, in case more/less columns are in the spreadsheet or if columns not related to grades are added at the end (such as Finalized). My coworker may need Math/History/Science Grade 4 or 5 or 6. You get the idea.
Before macro is run:
After macro is run:
Sub CreateGrades()
Dim TempString As String
TempString = ""
Application.ScreenUpdating = False ' Ensure we aren't spamming the graphics engine
Dim TheLastRow As Long
TheLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
Columns("G:G").Select
Selection.Insert Shift:=xlToRight ', CopyOrigin:=xlFormatFromLeftOrAbove
Columns("H:H").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("I:I").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("G:G").Select
TempString = "IF(AND(ISNUMBER(RC[4]), RC[4]>0),""1,"","""")&IF(AND(ISNUMBER(RC[7]), RC[7]>0),""2,"","""")&IF(AND(ISNUMBER(RC[10]), RC[10]>0),""3,"","""")"
Selection.FormulaR1C1 = "=IF(LEN(" + TempString + ") > 0, LEFT( " + TempString + ", LEN( " + TempString + " ) - 1 ), " + TempString + " )"
Columns("G:G").EntireColumn.AutoFit
Range("G1").Select
ActiveCell.FormulaR1C1 = "Math"
Columns("H:H").Select
TempString = "IF(AND(ISNUMBER(RC[4]), RC[4]>0),""1,"","""")&IF(AND(ISNUMBER(RC[7]), RC[7]>0),""2,"","""")&IF(AND(ISNUMBER(RC[10]), RC[10]>0),""3,"","""")"
Selection.FormulaR1C1 = "=IF(LEN(" + TempString + ") > 0, LEFT( " + TempString + ", LEN( " + TempString + " ) - 1 ), " + TempString + " )"
Columns("H:H").EntireColumn.AutoFit
Range("H1").Select
ActiveCell.FormulaR1C1 = "History"
Columns("I:I").Select
TempString = "IF(AND(ISNUMBER(RC[4]), RC[4]>0),""1,"","""")&IF(AND(ISNUMBER(RC[7]), RC[7]>0),""2,"","""")&IF(AND(ISNUMBER(RC[10]), RC[10]>0),""3,"","""")"
Selection.FormulaR1C1 = "=IF(LEN(" + TempString + ") > 0, LEFT( " + TempString + ", LEN( " + TempString + " ) - 1 ), " + TempString + " )"
Columns("I:I").EntireColumn.AutoFit
Range("I1").Select
ActiveCell.FormulaR1C1 = "Science"
' Draw borders around the maps, and shade/color the cells
Call HighlightAllDataMaps(TheLastRow)
' Draw the legend at the top
Call DrawInstructions("AllData")
ActiveSheet.name = "All Grades"
' If we aren't already filtering, then turn it on
If ActiveSheet.AutoFilterMode = False Then
[a3].Select
Selection.AutoFilter
End If
Rows("1:1").Select
Selection.Activate
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Rows("1:1").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
End Sub
One idea I had was to use COUNTIFS to look for columns that have Math, Science, and History, but I know that impacts the code dramatically. I did try it with my current code, just to see if it'd work. It does work, but it took my macro 6 minutes to run! I switched out the current TempString for the following:
TempString = "IF(COUNTIFS(R1C[4],""*Math*"", RC[4], "">0""),""1,"","""")&IF(COUNTIFS(R1C[7],""*Math*"", RC[7], "">0""),""2,"","""")&IF(COUNTIFS(R1C[10],""*Math*"", RC[10], "">0""),""3,"","""")&IF(COUNTIFS(R1C[13],""*Math*"", RC[13], "">0""),""4,"","""")&IF(COUNTIFS(R1C[16],""*Math*"", RC[16], "">0""),""5,"","""")&IF(COUNTIFS(R1C[19],""*Math*"", RC[19], "">0""),""6,"","""")&IF(COUNTIFS(R1C[22],""*Math*"", RC[22], "">0""),""7,"","""")&IF(COUNTIFS(R1C[25],""*Math*"", RC[25], "">0""),""4,"","""")"
That gets around the issue of non-Grade columns getting counted, but performance really takes a hit. My mind is spent. Any help would greatly be appreciated.
When using an array equation, the processing speed becomes slow if there is a lot of data. It is better to assign values than to use formulas.
Ty,
Sub CreateGrades()
Dim TempString As String
Dim vDB As Variant, vR() As Variant
Dim rngDB As Range
Dim r As Long, i As Long
Dim j As Integer, k As Integer, n As Integer
Dim s As String
TempString = ""
'Application.ScreenUpdating = False ' Ensure we aren't spamming the graphics engine
Dim TheLastRow As Long
TheLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
Range("g:i").Insert
Range("g1").Resize(1, 3) = Array("Math", "History", "Science")
Set rngDB = Range("a1").CurrentRegion
vDB = rngDB
r = UBound(vDB, 1)
c = UBound(vDB, 2)
For i = 2 To r
For j = 7 To 9
n = 0
Erase vR
For k = 10 To c
If vDB(i, k) <> "" Then
s = vDB(1, k) 'Grade 1 Math or Math Grade 1
If InStr(s, vDB(1, j)) Then
s = Trim(Replace(s, vDB(1, j), ""))
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = Right(s, 1)
End If
End If
Next k
If n Then
vDB(i, j) = Join(vR, ",")
End If
Next j
Next i
rngDB = vDB
'' Draw borders around the maps, and shade/color the cells
'Call HighlightAllDataMaps(TheLastRow)
'
'' Draw the legend at the top
'Call DrawInstructions("AllData")
'
'ActiveSheet.Name = "All Grades"
'
'' If we aren't already filtering, then turn it on
'If ActiveSheet.AutoFilterMode = False Then
' [a3].Select
' Selection.AutoFilter
'End If
'
'Rows("1:1").Select
'Selection.Activate
'With Selection.Font
' .ColorIndex = xlAutomatic
' .TintAndShade = 0
'End With
'
'Rows("1:1").Select
'With ActiveWindow
' .SplitColumn = 0
' .SplitRow = 1
'End With
'ActiveWindow.FreezePanes = True
End Sub

From data in an excel file, write new excel files populated with data based on a column's value

I am essentially trying to slice my "master excel" file into a bunch of new files using the same data. I am able to create the new file, make an entry and then save; however, I am unable to add multiple entries into one file. I feel like I'm brain farting on some basic coding logic.
The master excel file looks as follows:
A B C D
1 XXX-01 100 Description1 4
2 XXX-01 104 Description2 2
3 XXX-01 209 Description3 3
4 XXX-02 102 Description4 5
5 XXX-02 355 Description5 1
6 XXX-02 322 Description6 1
7 XXX-02 943 Description7 9
8 XXX-02 231 Description8 4
9 XXX-03 124 Description9 4
10 XXX-03 555 Description10 2
Where
A: GroupID
B: Part_Number
C: Description
D: Quantity
My desire, from the above, would to make 3 excel files (XXX-01, XXX-02, XXX-03) where each file contains it's respective data.
For instance, XXX-01.xlsx would look like the following:
A B C D
1 Item# Part Description Qty
2 1 100 Description1 4
3 2 104 Description2 2
4 3 209 Description3 3
Where row 1 is for headers that are the same for each XXX-## file.
In order to establish a baseline of where my code is at: the following works to create the file insert one row, but will then close and overwrite the previous file. (Stolen from: Create, name, and populate new workbook with data)
Sub CreateBooks()
Dim oCell As Excel.Range
Dim oWorkbook As Excel.Workbook
Application.DisplayAlerts = False
For Each oCell In Range("A:A")
If oCell.Value = "" Then Exit For
Set oWorkbook = Workbooks.Add
oWorkbook.Sheets(1).Cells(1, 1).Value = oCell.Offset(0, 1).Value
oWorkbook.Close True, oCell.Value
Next oCell
Application.DisplayAlerts = True
End Sub
I added the following in order to insert my save path into column A of the Master:
Dim Path As String
Path = "C:\Users\MyComputer\Documents"
For Each oCell In Range("A:A")
If oCell.Value = "" Then Exit For
oCell.Value = Path & oCell.Value
Next oCell
My goal with the below edits was to get the for loop to repeat if the cell below oCell is equivalent to the value of oCell. Perhaps a Do While loop would be more applicable here; however.
Dim Row_Counter As Integer
For Each oCell In Range("A:A")
If oCell.Value = "" Then Exit For
Set oWorkbook = Workbooks.Add
oWorkbook.Sheets(1).Cells(Row_Counter, 2).Value = oCell.Offset(0, 1).Value
oWorkbook.Sheets(1).Cells(Row_Counter, 3).Value = oCell.Offset(0, 2).Value
oWorkbook.Sheets(1).Cells(Row_Counter, 4).Value = oCell.Offset(0, 3).Value
For Each Next_oCell In Range("A:A")
If Next_oCell.Value = oCell.Value Then
Row_Counter = Row_Counter + 1
oWorkbook.Sheets(1).Cells(Row_Counter, 2).Value = Next_oCell.Offset(0, 1).Value
oWorkbook.Sheets(1).Cells(Row_Counter, 3).Value = Next_oCell.Offset(0, 2).Value
oWorkbook.Sheets(1).Cells(Row_Counter, 4).Value = Next_oCell.Offset(0, 3).Value
End If
Next Next_oCell
That being said, I am still only getting the one file that is being overwritten. I think my issue (or at least one of them) is that I don't have a means of saying "go through all rows with this value in column A, then skip to the first row with a new number."
Any help would be greatly appreciated!
Here's one approach:
Sub Divide()
Dim dict As Object, v, k, c As Range, i As Long, sht As Worksheet
Set dict = CreateObject("scripting.dictionary")
'collect all the distinct values and matching cell references
For Each c In Range("A:A")
v = c.Value
If Len(v) = 0 Then Exit For
If Not dict.exists(v) Then dict.Add v, New Collection 'new key if needed
dict(v).Add c 'add the cell to the appropriate collection
Next c
'process each group id in turn
For Each k In dict.keys
'create and save a workbook (to the same location as this workbook)
With Workbooks.Add
.SaveAs ThisWorkbook.Path & "\" & k & ".xlsx"
.Sheets(1).Range("a1").Resize(1, 4).Value = _
Array("Item#", "Part", "Description", "Qty")
i = 1
'process each cell in the collection for this Group
For Each c In dict(k)
.Sheets(1).Cells(i + 1, 1).Value = i
.Sheets(1).Cells(i + 1, 2).Resize(1, 3).Value = _
c.Offset(0, 1).Resize(1, 3).Value
i = i + 1
Next c
.Close True 'save changes
End With
Next k
End Sub
Does this solution work?
Sub SeperateMasterFile()
'
' This part of the macro sorts Column A in Ascending Order
Dim lRowD As Long
Dim lRowA As Long
'Find the last non-blank cell in column D(4)
lRowD = Cells(Rows.Count, 4).End(xlUp).Row
'
'Find the last non-blank cell in column A(1)
lRowA = Cells(Rows.Count, 1).End(xlUp).Row
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:D" & lRowD)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim LastI As Integer
Dim NewValueInColumnA As String
Dim NewValueInColumnARowNumber As Integer
For I = 1 To lRowA + 1
LastI = I - 1
'If LastI = 0 then we will make LastI = 1, because Range"(A0)".select would be invalid
If LastI = 0 Then
I = 1
End If
'When the For loop starts the following if statement
'will put the value in A1 into the variable NewValueInColumnA
If NewValueInColumnA = "" Then
NewValueInColumnA = Range("A1").Text
NewValueInColumnARowNumber = 1
End If
If NewValueInColumnA = Range("A" & I) Then
Else
'If A3 has a different value to A2, then the following code selects A1:D2
'If A7 has a different value to A6, then the following code selects A3:D6
Range("A" & NewValueInColumnARowNumber & ":D" & LastI).Select
NewValueInColumnARowNumber = I
NewValueInColumnA = Range("A" & I)
'The following code now runs the macro called 'MoveToNewWorkBook'
Call MoveToNewWorkbook
End If
Next I
End Sub
Sub MoveToNewWorkbook()
'
' MoveToNewWorkbook Macro
'
Selection.Copy
Workbooks.Add
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Value = "Item#"
Range("B1").Value = "Part"
Range("C1").Value = "Description"
Range("D1").Value = "QTY"
ActiveWorkbook.SaveAs Filename:="C:\Users\HP\Documents\" & Range("A2").Text & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
End Sub

VBA and Excel optimization of processing time, dealing with several rows

Hello StackOverflowers,
I need som help here.
I have been working on a VBA code but it is taking around 20 to 30 mins to process the data and I need some advise to reduce the amount the processing time.
I have 3 sheets in the document.
1- Sheet 1 is called "ExtractData".
That sheet contains 3 columns:
Column A: contains "Environment: PROD, Pre-Prod & UAT", responsible fetching the data based on the environment stated in the dropdown list.
That column contains also a possibility to parse the html text contained in some cells
Column B: Contain list of Product Code
Column C: contains name of fields / attribute for which we need the data for.
Also, we have a button in that sheet that should run the code to fetch the data and display them in sheet called "Source Data"
2- Sheet 2: Called "DataReview", containing extracted data, then I copy data content from cell A2:MJ500 and paste it in sheet 3 (Source Data) that contains some predefined headers.
So I paste data from A4
3- Sheet 3 called: "Source Data"
That sheet will display all data fetched based on the stated attribute
CASE 1: What I am supposed to do, is to filter the data based on some variable and transpose them in a separate sheet:
Exemple 1: May via a VBA buttong, I select specific attribute, like filter based on "Product Family", when you click run, it will copy the data,
then transpose them in a specific way in a separate sheet named after the Product family name
BUT, I tried, different ways and I am not getting what I wanted.
Below find the code I am using, please go through it and help me make it better.
Function Get_File(Enviromment As String, Pos_row As Integer, Data_date As String) As String
Dim objRequest As Object
Dim blnAsync As Boolean
Dim strResponse As String
Dim Token As String
Dim Url As String
Dim No_product_string As String
Token = "xxxxxxxx"
Url = CreateURL(Enviromment, Pos_row, Data_date)
Set objRequest = CreateObject("MSXML2.XMLHTTP")
blnAsync = True
With objRequest
.Open "GET", Url, blnAsync
.SetRequestHeader "Content-Type", "application/json"
.SetRequestHeader "x-auth-token", "xxxxxxxx"
.Send
'spin wheels whilst waiting for response
While objRequest.ReadyState <> 4
DoEvents
Wend
strResponse = .ResponseText
End With
Debug.Print strResponse
Get_File = strResponse
End Function
Function CreateURL(Enviroment As String, Pos_row As Integer, Data_date As String)
Dim product_code As String
If (StrComp(Enviroment, "UAT", vbTextCompare) = 0) Then
CreateURL = "https://TEST1-uat.Nothing.net:8096/api/products/hierarchies"
ElseIf (StrComp(Enviroment, "PPROD", vbTextCompare) = 0) Then
CreateURL = "https://TEST1-pprod.nothing.net:8096/api/products/hierarchies"
ElseIf (StrComp(Enviroment, "PROD", vbTextCompare) = 0) Then
CreateURL = "https://TEST1.nothing.net:8096/api/products/hierarchies"
Else
CreateURL = "https://TEST1.nothing.net:8096/api/products/hierarchies"
End If
If Pos_row <> -1 Then
product_code = ThisWorkbook.Sheets("DataReview").Cells(Pos_row, 1)
CreateURL = CreateURL & "?query=%7B%22productCode%22%3A%22" & product_code & "%22%7D"
End If
If Not (Trim(Data_date & "") = "") Then
CreateURL = Left(CreateURL, Len(CreateURL) - 3) & "%2C%22date%22%3A%22" & Data_date & "%22%7D"
End If
End Function
Function Get_value(Json_file As String, Field_name As String, Initial_value As String, Current_amount_values As Integer) As String
Dim tempString As String
Dim Value As String
Dim Field_name_temp As String
Field_name_temp = "my_" & Field_name 'Ensure that field name is not subset of other field name
Value = Initial_value
Pos_field = InStr(Json_file, Field_name_temp & """:")
tempString = Mid(Json_file, Pos_field + Len(Field_name_temp) + 4)
'MsgBox (Mid(tempString, 1, 75))
If Not StrComp(Left(tempString, 1), "}") Then
Value = Value & "," & ""
Else
Value = Value & "$" & Replace(Split(tempString, "]")(0), """", "")
End If
If Not InStr(tempString, Field_name_temp & """:") = 0 Then
Value = Get_value(tempString, Field_name, Value, Current_amount_values + 1)
End If
Get_value = Value
End Function
Sub Set_value(Value As String, Pos_col As Integer, Pos_row As Integer, Pos_row_max As Integer)
Dim i As Integer
Dim HTML As String
HTML = ThisWorkbook.Sheets("ExtractData").Range("A8")
If HTML = "Yes" Or HTML = "" Then
Value = ParseHTML(Value)
End If
If Value <> "" Then
If UBound(Split(Value, "$")) = 0 Then
ThisWorkbook.Sheets("DataReview").Cells(Pos_row, Pos_col).Value = Value
Else
If Pos_row < Pos_row_max And ThisWorkbook.Sheets("DataReview").Cells(Pos_row + 1, 1) <> "" Then
ThisWorkbook.Sheets("DataReview").Cells(Pos_row, Pos_col).Value = Split(Value, "$")(0)
For i = 1 To UBound(Split(Value, "$"))
ThisWorkbook.Sheets("DataReview").Cells(Pos_row, Pos_col).Offset(1).EntireRow.Insert
ThisWorkbook.Sheets("DataReview").Cells(Pos_row + 1, Pos_col).Value = Split(Value, "$")(i)
Next i
End If
ThisWorkbook.Sheets("DataReview").Cells(Pos_row, Pos_col).Value = Split(Value, "$")(0)
For i = 1 To UBound(Split(Value, "$"))
ThisWorkbook.Sheets("DataReview").Cells(Pos_row + i, Pos_col).Value = Split(Value, "$")(i)
Next i
End If
End If
End Sub
Public Function ParseHTML(ByVal Value As String) As String
Dim htmlContent As New HTMLDocument
htmlContent.body.innerHTML = Value
ParseHTML = htmlContent.body.innerText
End Function
Sub Main_script()
Dim Pos_col As Integer, Pos_row As Integer, Json_file As String, Field_name As String
Dim Value As String
Dim i As Integer
Dim tempValue As String
Dim Pos_row_max As Integer
Dim Enviromment As String
Dim Data_date As String
Pos_col = 2
Pos_row = 2
Call Prepare_sheet
Data_date = Format(ThisWorkbook.Sheets("ExtractData").Range("A5"), "YYYY-MM-DD")
Enviromment = ThisWorkbook.Sheets("ExtractData").Range("A2")
Do While Not IsEmpty(ThisWorkbook.Sheets("DataReview").Cells(Pos_row, 1).Value)
Json_file = Get_File(Enviromment, Pos_row, Data_date)
Do While Not IsEmpty(ThisWorkbook.Sheets("DataReview").Cells(1, Pos_col).Value)
Field_name = ThisWorkbook.Sheets("DataReview").Cells(1, Pos_col).Value
Value = Mid(Get_value(Json_file, Field_name, "", 0), 2) 'Mid() is used to remove "," from the front of values
Pos_row_max = Application.Max(Pos_row_max, Pos_row + UBound(Split(Value, "$")))
Call Set_value(Value, Pos_col, Pos_row, Pos_row_max)
Pos_col = Pos_col + 1
Loop
Pos_col = 2
Pos_row = Pos_row_max + 1
Loop
ThisWorkbook.Sheets("DataReview").Activate
'Columns.AutoFit
'Rows.AutoFit
Cells.Select
Selection.ColumnWidth = 32
Selection.RowHeight = 15
ThisWorkbook.Sheets("DataReview").Range("A2:HM10000").Select
Selection.Copy
Sheets("Source Data").Select
Sheets("Source Data").Range("A4:HM14000").Select
ActiveSheet.Paste
ThisWorkbook.Sheets("Source Data").Activate
End Sub
Sub Prepare_sheet()
Dim i As Integer
Dim j As Integer
i = 2
j = 2
ThisWorkbook.Sheets("DataReview").Range("A1:HH10000").ClearContents
Do While ThisWorkbook.Sheets("ExtractData").Cells(i, 2).Value <> ""
ThisWorkbook.Sheets("DataReview").Cells(i, 1).Value = ThisWorkbook.Sheets("ExtractData").Cells(i, 2).Value
i = i + 1
Loop
Do While ThisWorkbook.Sheets("ExtractData").Cells(j, 3).Value <> ""
ThisWorkbook.Sheets("DataReview").Cells(1, j).Value = ThisWorkbook.Sheets("ExtractData").Cells(j, 3).Value
j = j + 1
Loop
ThisWorkbook.Sheets("DataReview").Cells(1, 1).Value = "Product_code"
End Sub
Sub Insert_product_codes(Value As String)
For i = 1 To UBound(Split(Value, ","))
ThisWorkbook.Sheets("Data").Cells(i, 1).Value = Split(Value, ",")(i)
Next i
End Sub
Module 1 (Containing most of the code):
Module 2 (To transpose data): Here I transpose Data from "Source Data" sheet into "Report" sheet that contains some predefined values in column A
Sub Transpose_Data()
'
' Transpose_Data Macro
'
'
Sheets("Source Data").Select
Rows("4:500").Select
Selection.Copy
Sheets("QRA Report Main").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("B6:MJ6").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown
Range("B12:MJ12").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B17:MJ17").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B23:MJ23").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B28:MJ28").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B36:MJ36").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B45:MJ45").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B51:MJ51").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B54:MJ54").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("B61:MJ61").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Columns("B:NZ").Select
Range("B3").Activate
Selection.ColumnWidth = 30
With Selection
.HorizontalAlignment = xlRight
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
ActiveWorkbook.Save
End Sub
But again as i said, I do not get exactly what I need plus, the processing time is huge.
Try this, but note you'll need to fill in the section in the middle.
``
Sub Transpose_Data()
'
' Transpose_Data Macro
'
'
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Sheets("Source Data").Rows("4:500").Copy Sheets("QRA Report Main").Range("B4")
With Sheets("QRA Report Main")
.Range("B6:MJ6").Insert Shift:=xlDown
.Range("B12:MJ12").Resize(2).Insert Shift:=xlDown
.Range("B17:MJ17").Resize(2).Insert Shift:=xlDown
.Range("B23:MJ23").Resize(2).Insert Shift:=xlDown
' add rest in here
.Range("B61:MJ61").Resize(2).Insert Shift:=xlDown
With .Columns("B:NZ")
.ColumnWidth = 30
.HorizontalAlignment = xlRight
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
End With
ActiveWorkbook.Save
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
``

Cut the rows and paste in one cell above - Keep Getting Run Time error for the copy and paste areas don't match overlap

I have a sheet with thousands of rows and multiple columns. The heading of each row is one cell above the numbers. For examples
My Name
2 3 4 5 6
What I want to do is cut from 2 to 6 and paste it up to the last row.
Sub test2()
Dim rOriginalSelection As Range
Cells.Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Select Case direction
Case up
Set rOriginalSelection = Range("B11:O11" & lrow)
Case Else
Debug.Assert False
End Select
With rOriginalSelection
.Select
.Cut
Select Case direction
Case "up"
.Offset(-1, 0).Select
End Select
End With
Selection.Insert
rOriginalSelection.Select
Yeah, you can do that using code like this. It moves one row at a time.
Sub Macro1()
' We don't know how long the file is. If we find more than 4 consequent
' empty cells in column A, we should stop looping
Dim EmptyCellCount As Integer
' Row number to start from
Dim MyRow As Integer
EmptyCellCount = 0
MyRow = 1
Do While EmptyCellCount < 5
' select A1 and check if there's any content in it
Range("A" & MyRow).Select
If Len(Trim(Range("A" & MyRow).Text)) > 0 Then
' select content from the next line and put in the current line
Range("C" & MyRow + 1 & ":Q" & MyRow + 1).Select
Selection.Cut
Range("C" & MyRow).Select
ActiveSheet.Paste
' switch to the next row and reset empty cell count
MyRow = MyRow + 1
EmptyCellCount = 0
Else
' switch to the next row and increment empty cell count
MyRow = MyRow + 1
EmptyCellCount = EmptyCellCount + 1
End If
Loop
End Sub
This one moves the entire block one row up
Sub Macro2()
Dim EmptyCellCount As Integer
Dim MyRow As Integer
MyRow = 1
' Find the cell where the last A cell is filled, approximately
Do While EmptyCellCount < 3
If Len(Trim(Range("A" & MyRow).Text)) > 0 Then
EmptyCellCount = 0
Else
EmptyCellCount = EmptyCellCount + 1
End If
MyRow = MyRow + 1
Loop
' Move the entire block up one row
Range("C2:Q" & MyRow).Select
Selection.Cut
Range("C1").Select
ActiveSheet.Paste
End Sub

Resources