Related
I have written a VBA macro for automating part of my work. It was written on laptop which is based on Russian (date/keyboard) settings.
Somehow when I run it on external PC ( based on German in Austria ) It doesn't perform the same way, it gives me wrong results and error - 'run time error '13' type mismatch'
Sub Proverka()
nm = ActiveSheet.Name
Sheets.Add.Name = "mediana"
Worksheets(nm).Select
n = Cells(Rows.Count, 1).End(xlUp).Row
Summa = 0
Kol = 0
k = 1
For i = 2 To n
Cells(i, 4) = Replace(Cells(i, 4), " Days", "")
If Cells(i, 1) = "Resolved-Issued" And Format(Cells(i, 2), "mmmm") = Format(DateAdd("m", -1, Date), "mmmm") And Format(Cells(i, 2), "yyyy") = Format(DateAdd("m", -1, Date), "yyyy") And Cells(i, 13) = "TFO" Then
If Cells(i, 5) <> "" Then KolD = DateDiff("d", Cells(i, 3), CDate(Split(Cells(i, 5), "/")(1) & "." & Split(Cells(i, 5), "/")(0) & "." & Split(Cells(i, 5), "/")(2)))
KolDV = 0
D = CDate(Cells(i, 3))
For i2 = 1 To KolD
If Format(D, "dddd") = "saturday" Or Format(D, "dddd") = "sunday" Then
KolDV = KolDV + 1
End If
D = DateAdd("d", 1, D)
Next i2
Cells(i, 4) = Cells(i, 4) - KolDV
Worksheets("mediana").Cells(k, 1) = Cells(i, 4)
k = k + 1
End If
Next i
Cells(n + 2, 1) = "Median " & Format(DateAdd("m", -1, Date), "mmmm")
Cells(n + 3, 1) = "Average " & Format(DateAdd("m", -1, Date), "mmmm")
a = WorksheetFunction.Average(Range(Worksheets("mediana").Cells(1, 1), Worksheets("mediana").Cells(k - 1, 1)))
m = WorksheetFunction.Median(Range(Worksheets("mediana").Cells(1, 1), Worksheets("mediana").Cells(k - 1, 1)))
'Worksheets("mediana").Delete
Cells(n + 2, 4) = m
Cells(n + 3, 4) = a
MsgBox "OK"
End Sub
For very large Excel csv files (can be as large as 35MB+ & >100k rows), one of my processing steps is to check column A's "record type" indicator and depending on the value, cut/paste 2 sequential cells from different places in the row, over to the end of the row (columns 51 & 52).
The following code passed the 'CompileVBAProject' test, but I'm certain there are more efficient, much faster scripts that I'm just not thinking of. Yes, I'm a VBA semi-noob, but I'm trying to get better fast. Got any advice?
For i = 4 To rng.Rows.Count
If Cells(i, 1).Value = "10EE" Then
Range("AW" & i & ":AY" & i).Copy Cells(i, 50)
Range("AW" & i).ClearContents
Else
If Cells(i, 1).Value = "05EE" Then
Range("M" & i & ":N" & i).Copy Cells(i, 51)
Range("M" & i & ":N" & i).ClearContents
Else
If (Cells(i, 1).Value = "11EE" Or Cells(i, 1).Value = "25CP" Or Cells(i, 1).Value = "26EP" _
Or Cells(i, 1).Value = "51CL" Or Cells(i, 1).Value = "60PM") Then
Range("L" & i & ":M" & i).Copy Cells(i, 51)
Range("L" & i & ":M" & i).ClearContents
Else
If Cells(i, 1).Value = "15EM" Then
Range("M" & i & ":N" & i).Copy Cells(i, 51)
Range("M" & i & ":N" & i).ClearContents
Else
If Cells(i, 1).Value = "17EA" Then
Range("X" & i & ":Y" & i).Copy Cells(i, 51)
Range("X" & i & ":Y" & i).ClearContents
Else
If Cells(i, 1).Value = "20DP" Then
Range("AC" & i & ":AD" & i).Copy Cells(i, 51)
Range("AC" & i & ":AD" & i).ClearContents
Else
If Cells(i, 1).Value = "24AH" Then
Range("AD" & i & ":AE" & i).Copy Cells(i, 51)
Range("AD" & i & ":AE" & i).ClearContents
Else
If Cells(i, 1).Value = "30EL" Then
Range("V" & i & ":W" & i).Copy Cells(i, 51)
Range("V" & i & ":W" & i).ClearContents
Else
If Cells(i, 1).Value = "31EL" Then
Range("O" & i & ":P" & i).Copy Cells(i, 51)
Range("O" & i & ":P" & i).ClearContents
Else
If Cells(i, 1).Value = "40DE" Then
Range("R" & i & ":S" & i).Copy Cells(i, 51)
Range("R" & i & ":S" & i).ClearContents
Else
If Cells(i, 1).Value = "50CL" Then
Range("AB" & i & ":AC" & i).Copy Cells(i, 51)
Range("AB" & i & ":AC" & i).ClearContents
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
Next i
If you are using Set rng = Application.Range("A4:A" & lrow) then For i = 4 To rng.Rows.Count is incorrect.
A Select Case seems ideal for this. I combined "05EE" and "15EM".
with worksheets(1)
For i = 4 To lrow
Select Case .Cells(i, 1).Value2
Case "10EE"
.Cells(i, "AX").Resize(1, 3) = .Cells(i, "AW").Resize(1, 3).Value2
.Cells(i, "AW").ClearContents
Case "05EE", "15EM"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "M").Resize(1, 2).Value2
.Cells(i, "M").Resize(1, 2).ClearContents
Case "11EE", "25CP", "26EP", "51CL", "60PM"
.Cells(i, "AY").Resize(1, 3) = .Cells(i, "L").Resize(1, 3).Value2
.Cells(i, "L").Resize(1, 3).ClearContents
Case "17EA"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "X").Resize(1, 2).Value2
.Cells(i, "X").Resize(1, 2).ClearContents
Case "20DP"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "AC").Resize(1, 2).Value2
.Cells(i, "AC").Resize(1, 2).ClearContents
Case "24AH"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "AD").Resize(1, 2).Value2
.Cells(i, "AD").Resize(1, 2).ClearContents
Case "30EL"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "V").Resize(1, 2).Value2
.Cells(i, "V").Resize(1, 2).ClearContents
Case "31EL"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "O").Resize(1, 2).Value2
.Cells(i, "O").Resize(1, 2).ClearContents
Case "40DE"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "R").Resize(1, 2).Value2
.Cells(i, "R").Resize(1, 2).ClearContents
Case "50CL"
.Cells(i, "AY").Resize(1, 2) = .Cells(i, "AB").Resize(1, 2).Value2
.Cells(i, "AB").Resize(1, 2).ClearContents
Case Else
'do nothing
End Select
Next i
end with
If there are certain values that occur more frequently, they should be at the top of the Case conditions.
Another way to structure the data, and use arrays:
Option Explicit
Public Sub CopyVals()
Const START_ROW = 4
Dim ws As Worksheet, rng As Range, map As Variant, arr As Variant, mapUb As Long
Set ws = Sheet3 'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
Set rng = ws.UsedRange
arr = rng 'Copy Range to Array
map = GetMapping(map) 'Get Mapping: Values to Columns
mapUb = UBound(map)
Dim r As Long, i As Long, j As Long
For r = START_ROW To rng.Rows.Count
For i = 1 To mapUb
If arr(r, 1) = map(i, 1) Then
For j = 0 To map(i, 4) 'map4 = Offset col
' map3 = copyTo col map2 = copyFrom col
arr(r, map(i, 3) + j) = arr(r, map(i, 2) + j)
Next
End If
Next
Next
rng.Offset(rng.Rows.Count + 1, 0) = arr
End Sub
Private Function GetMapping(ByRef map As Variant) As Variant
Const ITM = "10EE 05EE 11EE 25CP 26EP 51CL 60PM 15EM 17EA 20DP 24AH 30EL 31EL 40DE 50CL"
Const SRC = "49 13 12 12 12 12 12 13 24 29 30 22 15 18 28"
Const DST = "50 51 51 51 51 51 51 51 51 51 51 51 51 51 51"
Const OFF = "2 1 1 1 1 1 1 1 1 1 1 1 1 1 1" 'Total columns to copy From / To + 1
Dim v As Variant, s As Variant, d As Variant, o As Variant, i As Long
v = Split(ITM)
s = Split(SRC)
d = Split(DST)
o = Split(OFF)
ReDim map(1 To UBound(v) + 1, 1 To 4) As Variant
For i = 1 To UBound(v) + 1
map(i, 1) = v(i - 1) 'Values
map(i, 2) = s(i - 1) 'From First Col
map(i, 3) = d(i - 1) 'To First Col
map(i, 4) = o(i - 1) 'Total Cols (both From and To)
Next
GetMapping = map
End Function
.
Map Array returned by GetMapping()
Value From First Col To First Col Total Cols (+ 1)
map( 1, 1) = "10EE": map( 1, 2) = 49: map( 1, 3) = 50: map( 1, 4) = 2
map( 2, 1) = "05EE": map( 2, 2) = 13: map( 2, 3) = 51: map( 2, 4) = 1
map( 3, 1) = "11EE": map( 3, 2) = 12: map( 3, 3) = 51: map( 3, 4) = 1
map( 4, 1) = "25CP": map( 4, 2) = 12: map( 4, 3) = 51: map( 4, 4) = 1
map( 5, 1) = "26EP": map( 5, 2) = 12: map( 5, 3) = 51: map( 5, 4) = 1
map( 6, 1) = "51CL": map( 6, 2) = 12: map( 6, 3) = 51: map( 6, 4) = 1
map( 7, 1) = "60PM": map( 7, 2) = 12: map( 7, 3) = 51: map( 7, 4) = 1
map( 8, 1) = "15EM": map( 8, 2) = 13: map( 8, 3) = 51: map( 8, 4) = 1
map( 9, 1) = "17EA": map( 9, 2) = 24: map( 9, 3) = 51: map( 9, 4) = 1
map(10, 1) = "20DP": map(10, 2) = 29: map(10, 3) = 51: map(10, 4) = 1
map(11, 1) = "24AH": map(11, 2) = 30: map(11, 3) = 51: map(11, 4) = 1
map(12, 1) = "30EL": map(12, 2) = 22: map(12, 3) = 51: map(12, 4) = 1
map(13, 1) = "31EL": map(13, 2) = 15: map(13, 3) = 51: map(13, 4) = 1
map(14, 1) = "40DE": map(14, 2) = 18: map(14, 3) = 51: map(14, 4) = 1
map(15, 1) = "50CL": map(15, 2) = 28: map(15, 3) = 51: map(15, 4) = 1
I would like to ask how to shorten the code below? Have any other ways to achieve the same result?
Option Explicit
Sub test()
Dim i As Integer
Dim nRow As Integer: nRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To nRow
If Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) And Cells(i + 3, 1) = Cells(i + 4, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2) & "/" & Cells(i + 4, 2)
Rows(i + 1 & ":" & i + 4).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2)
Rows(i + 1 & ":" & i + 3).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2)
Rows(i + 1 & ":" & i + 2).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2)
Rows(i + 1 & ":" & i + 1).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) = "" Then
Exit For
End If
Next i
End Sub
Thank you!
Here's Dictionary based approach which should work for you.
Public Sub RearrangeData()
Dim objDic As Object
Dim varRng
Dim i As Long
Set objDic = CreateObject("Scripting.Dictionary")
objDic.CompareMode = vbTextCompare '\\ change this if you need it case sensitive
varRng = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
For i = LBound(varRng) To UBound(varRng)
If objDic.Exists(varRng(i, 1)) Then
objDic.Item(varRng(i, 1)) = objDic.Item(varRng(i, 1)) & "/" & varRng(i, 2)
Else
objDic.Add varRng(i, 1), varRng(i, 2)
End If
Next i
Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
Range("A2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Keys)
Range("B2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Items)
Set objDic = Nothing
End Sub
here's another dictionary approach (no reference adding required)
Sub strings()
Dim data As Variant, key As Variant
Dim i As Long
data = Range("B2", Cells(Rows.Count, 1).End(xlUp)).Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(data)
.Item(data(i, 1)) = .Item(data(i, 1)) & "/" & data(i, 2)
Next
Range("A1").CurrentRegion.Resize(Range("A1").CurrentRegion.Rows.Count - 1).Offset(1).ClearContents
i = 1
For Each key In .Keys
i = i + 1
Cells(i, 1) = key
Cells(i, 2) = Mid(.Item(key), 2)
Next
End With
End Sub
BTW, should you ever need to combine strings from more columns, you could use
Option Explicit
Sub strings()
Dim data As Variant, key As Variant
Dim i As Long, iCol As Long
With Range("A1").CurrentRegion
With .Resize(.Rows.Count - 1).Offset(1)
data = .Value
.ClearContents
End With
End With
With CreateObject("Scripting.Dictionary")
For iCol = 2 To UBound(data, 2)
For i = 1 To UBound(data)
.Item(data(i, 1)) = Trim(.Item(data(i, 1)) & " " & data(i, iCol))
Next
Range("A2").Resize(.Count) = Application.Transpose(.Keys)
Range("A2").Resize(.Count).Offset(, iCol - 1) = Application.Transpose(.Items)
.RemoveAll
Next
End With
Range("a1").CurrentRegion.Replace what:=" ", replacement:="/", lookat:=xlPart
End Sub
Above is what the code below does.
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim i As Long
Dim k As Long
Set ws = ActiveSheet
With ws
For i = 1 To 200
If Left(.Cells(i, 1).Value, 2) = "HW" Then
On Error Resume Next
k = .Range(.Cells(i + 1, 1), .Cells(200, 1)).Find("HW").Row
On Error GoTo 0
If k <= i Then k = 200
.Cells(i, 10).Value = Len(Cells((i + 2), 1).Value) - Len(Replace(Cells((i + 2), 1).Value, ",", "")) + 1
.Cells(i, 11).Value = "SET"
.Cells(i, 12).Resize(k - i).Value = .Cells(i, 1).Resize(k - i).Value
.Cells((i + 1), 12).Resize(k - i).Value = .Cells((i + 1), 1).Resize(k - i).Value
.Cells((i + 2), 12).Resize(k - i).Value = ws.Cells((i + 2), 1).Resize(k - i).Value
.Cells((i + 3), 12).Resize(k - i).Value = ""
.Cells((i + 4), 12).Resize(k - i).Value = "QTY"
.Cells((i + 4), 13).Resize(k - i).Value = "TYPE"
.Cells((i + 4), 15).Resize(k - i).Value = "LENGTH"
.Cells((i + 4), 16).Resize(k - i).Value = "FINISH"
.Cells((i + 4), 19).Resize(k - i).Value = "LIST"
.Cells((i + 4), 20).Resize(k - i).Value = "NET"
.Cells((i + 4), 21).Resize(k - i).Value = "MFG"
.Cells((i + 4), 22).Resize(k - i).Value = "MODEL"
.Cells((i + 5), 12).Resize(k - i).Value = .Cells((i + 3), 1).Resize(k - i).Value
.Cells((i + 5), 13).Resize(k - i).Value = .Cells((i + 3), 2).Resize(k - i).Value
.Cells((i + 5), 15).Resize(k - i).Value = .Cells((i + 3), 5).Resize(k - i).Value
.Cells((i + 5), 16).Resize(k - i).Value = .Cells((i + 3), 6).Resize(k - i).Value
.Cells((i + 5), 19).Resize(k - i).Value = .Cells((i + 3), 7).Resize(k - i).Value
.Cells((i + 5), 20).Resize(k - i).Value = .Cells((i + 3), 8).Resize(k - i).Value
.Cells((i + 5), 21).Resize(k - i).Value = .Cells((i + 3), 3).Resize(k - i).Value
.Cells((i + 5), 22).Resize(k - i).Value = .Cells((i + 3), 4).Resize(k - i).Value
i = k + 1
End If
Next i
End With
End Sub
A couple problems. First I'm not sure why but for the second data output it is missing the # of doors, SET, and all the different hardware. It looks like it is skipping it?
Second problem is i do not know how to make my headings (QTY, TYPE, LENGTH, FINISH, LIST, NET, MFG, MODEL) bold using VBA code. I think i would use text.bold but i don't think i know how to word it correctly.I would also like to put a double line underneath them including column N but excluding Q and R.
Third I would like to sum my NET prices at the end of the NET column, but im not sure how to specify that cell. I would also like the cell to the right of it to divide the sum of the net by a specific cell.
Forth, I tried doing this,
"DOOR: " & ws.Cells((i + 2), 1).Resize(k - i).Value
This triggers an error because one is a string and the other is an integer. I thought i could use CStr(), but that does not work.
When all is coded correctly i would like it to look like this.
Thanks in advance for any help!
I would move all the title row into an Array. Then you can just resize the area and assign the array.
As to your problems:
1) Math, when adding rows and refering to data that does not add the rows also there is a lot of math. You were basically overwriting data as you went.
2) one way to format the bold is Range.Font.Bold = True. With that the borders are similar Range.Borders(XlEdgeBottom).LineStyle = xlDouble.
3) Again Lots and Lots of math, Sometimes it is trial and error to get it correct.
4) You can't do that with a resize, it does not like it
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim i As Long
Dim k As Long
Set ws = ActiveSheet
Dim ofst As Long
Dim ttlArr() As String
ttarr = Array("QTY", "TYPE", vbNullString, "LENGTH", "FINISH", vbNullString, vbNullString, "LIST", "NET", "MFG", "MODEL")
ofst = 0
With ws
For i = 1 To 200
If Left(.Cells(i, 1).Value, 2) = "HW" Then
On Error Resume Next
k = .Range(.Cells(i + 1, 1), .Cells(200, 1)).Find("HW").Row
On Error GoTo 0
If k <= i Then k = .Cells(i, 1).End(xlDown).Row + 2
.Cells(i + ofst, 11).Value = "SET"
.Cells(i + ofst, 12).Resize(2).Value = .Cells(i, 1).Resize(2).Value
If IsNumeric(.Cells((i + 2), 1).Value) Then
.Cells(i + ofst, 10).Value = Len("'" & Format(.Cells(i + 2, 1).Value, "#,##0")) - Len(Replace("'" & Format(.Cells(i + 2, 1).Value, "#,##0"), ",", "")) + 1
.Cells(i + ofst + 2, 12).Value = "Doors: " & Format(.Cells(i + 2, 1).Value, "#,##0")
Else
.Cells(i + ofst, 10).Value = Len(.Cells(i + 2, 1).Value) - Len(Replace(.Cells(i + 2, 1).Value, ",", "")) + 1
.Cells(i + ofst + 2, 12).Value = "Doors: " & .Cells(i + 2, 1).Value
End If
.Cells(i + ofst + 4, 12).Resize(, UBound(ttarr) + 1).Value = ttarr
.Cells(i + ofst + 4, 12).Resize(, UBound(ttarr) + 1).Font.Bold = True
.Cells(i + ofst + 4, 12).Resize(, 5).Borders(xlEdgeBottom).LineStyle = xlDouble
.Cells(i + ofst + 4, 19).Resize(, 4).Borders(xlEdgeBottom).LineStyle = xlDouble
ofst = ofst + 2
.Cells(i + ofst + 3, 12).Resize(k - i - 3).Value = .Cells(i + 3, 1).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 13).Resize(k - i - 3).Value = .Cells(i + 3, 2).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 15).Resize(k - i - 3).Value = .Cells(i + 3, 5).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 16).Resize(k - i - 3).Value = .Cells(i + 3, 6).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 19).Resize(k - i - 3).Value = .Cells(i + 3, 7).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 20).Resize(k - i - 3).Value = .Cells(i + 3, 8).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 21).Resize(k - i - 3).Value = .Cells(i + 3, 3).Resize(k - i - 3).Value
.Cells(i + ofst + 3, 22).Resize(k - i - 3).Value = .Cells(i + 3, 4).Resize(k - i - 3).Value
.Cells(i + ofst + k - i - 1, 20).Value = WorksheetFunction.Sum(.Cells(i + ofst + 3, 20).Resize(k - i - 4))
' Change the Range("H1") to your cell with the factor
.Cells(i + ofst + k - i - 1, 21).Value = .Cells(i + ofst + k - i - 1, 20).Value / .Range("H1")
.Cells(i + ofst - 2, 17).Value = .Cells(i + ofst + k - i - 1, 21).Value
.Cells(i + ofst - 2, 18).Value = .Cells(i + ofst + k - i - 1, 21).Value * .Cells(i + ofst - 2, 10).Value
i = k - 1
End If
Next i
End With
End Sub
I believe the problem with lost data had to do with finding the last occurrence of HW* when there was no terminating HW* to locate the end-of-record. Without seeing one or two HW records as a sample, this is the best I could figure out.
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim i As Long, k As Long, hw As Long, MX As Long
Set ws = ActiveSheet
With ws
MX = 200 'maybe MX = .cells(rows.count, 1).end(xlup).row
i = .Columns(1).Find(what:="HW*", after:=.Cells(MX, 1), lookat:=xlWhole).Row
k = .Columns(1).FindNext(after:=.Cells(i, 1)).Row
For hw = 1 To Application.CountIf(.Columns(1), "HW*")
If k <= i Then k = MX
Debug.Print i & ":" & k
.Cells(i, 10) = UBound(Split(.Cells(i + 2, 1).Value, Chr(44))) + 1
.Cells(i, 11).Value = "SET"
.Cells(i, 12).Resize(k - i).Value = .Cells(i, 1).Resize(k - i).Value
With .Cells(i + 4, 12)
.Resize(1, 11) = Array("QTY", "TYPE", vbNullString, _
"LENGTH", "FINISH", vbNullString, vbNullString, _
"LIST", "NET", "MFG", "MODEL")
With Union(.Cells(1, 1).Resize(1, 5), .Cells(1, 1).Resize(1, 5))
.Font.Bold = True
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
End With
End With
End With
.Cells((i + 5), 12).Resize(k - i).Value = .Cells((i + 3), 1).Resize(k - i).Value
.Cells((i + 5), 13).Resize(k - i).Value = .Cells((i + 3), 2).Resize(k - i).Value
.Cells((i + 5), 15).Resize(k - i).Value = .Cells((i + 3), 5).Resize(k - i).Value
.Cells((i + 5), 16).Resize(k - i).Value = .Cells((i + 3), 6).Resize(k - i).Value
.Cells((i + 5), 19).Resize(k - i).Value = .Cells((i + 3), 7).Resize(k - i).Value
.Cells((i + 5), 20).Resize(k - i).Value = .Cells((i + 3), 8).Resize(k - i).Value
.Cells((i + 5), 21).Resize(k - i).Value = .Cells((i + 3), 3).Resize(k - i).Value
.Cells((i + 5), 22).Resize(k - i).Value = .Cells((i + 3), 4).Resize(k - i).Value
i = .Columns(1).FindNext(after:=.Cells(k - 1, 1)).Row
k = .Columns(1).FindNext(after:=.Cells(i, 1)).Row
Next hw
End With
End Sub
Dim ws As Worksheet
Dim MyWSTarget As Worksheet
Dim i As Long
Dim k As Long
Set ws = ActiveSheet
Set MyWSTarget = Workbooks.Open("C:\MASTER_QT.xlsx").Sheets(1)
Dim ofst As Long
Dim ttlArr() As String
ttarr = Array("QTY", "TYPE", vbNullString, "LENGTH", "FINISH", vbNullString, vbNullString, "LIST", "NET", "MFG", "MODEL")
ofst = 17
With ws
For i = 1 To 200
If Left(ws.Cells(i, 1).Value, 2) = "HW" Then
On Error Resume Next
k = ws.Range(ws.Cells(i + 1, 1), ws.Cells(200, 1)).Find("HW").Row
On Error GoTo 0
If k <= i Then k = ws.Cells(i, 1).End(xlDown).Row + 2
MyWSTarget.Cells(i + ofst, 3).Value = "SET"
MyWSTarget.Cells(i + ofst, 4).Resize(2).Value = ws.Cells(i, 1).Resize(2).Value
If IsNumeric(MyWSTarget.Cells((i + 2), 1).Value) Then
MyWSTarget.Cells(i + ofst, 2).Value = Len("'" & Format(ws.Cells(i + 2, 1).Value, "#,##0")) - Len(Replace("'" & Format(ws.Cells(i + 2, 1).Value, "#,##0"), ",", "")) + 1
MyWSTarget.Cells(i + ofst + 2, 4).Value = "Doors: " & Format(ws.Cells(i + 2, 1).Value, "#,##0")
Else
MyWSTarget.Cells(i + ofst + 2, 4).Value = "Doors: " & ws.Cells(i + 2, 1).Value
End If
MyWSTarget.Cells(i + ofst + 4, 3).Resize(, UBound(ttarr) + 1).Value = ttarr
MyWSTarget.Cells(i + ofst + 4, 3).Resize(, UBound(ttarr) + 1).Font.Bold = True
MyWSTarget.Cells(i + ofst + 4, 3).Resize(, 5).Borders(xlEdgeBottom).LineStyle = xlDouble
MyWSTarget.Cells(i + ofst + 4, 10).Resize(, 4).Borders(xlEdgeBottom).LineStyle = xlDouble
ofst = ofst + 2
MyWSTarget.Cells(i + ofst + 3, 3).Resize(k - i - 3).Value = ws.Cells(i + 3, 1).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 4).Resize(k - i - 3).Value = ws.Cells(i + 3, 2).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 6).Resize(k - i - 3).Value = ws.Cells(i + 3, 5).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 7).Resize(k - i - 3).Value = ws.Cells(i + 3, 6).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 10).Resize(k - i - 3).Value = ws.Cells(i + 3, 7).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 11).Resize(k - i - 3).Value = ws.Cells(i + 3, 8).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 12).Resize(k - i - 3).Value = ws.Cells(i + 3, 3).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + 3, 13).Resize(k - i - 3).Value = ws.Cells(i + 3, 4).Resize(k - i - 3).Value
MyWSTarget.Cells(i + ofst + k - i - 1, 11).Value = WorksheetFunction.Sum(MyWSTarget.Cells(i + ofst + 3, 11).Resize(k - i - 4))
' Change the Range("H1") to your cell with the factor
MyWSTarget.Cells(i + ofst + k - i - 1, 12).Value = MyWSTarget.Cells(i + ofst + k - i - 1, 11).Value / MyWSTarget.Range("L12")
MyWSTarget.Cells(i + ofst - 2, 8).Value = MyWSTarget.Cells(i + ofst + k - i - 1, 12).Value
MyWSTarget.Cells(i + ofst - 2, 9).Value = MyWSTarget.Cells(i + ofst + k - i - 1, 12).Value * MyWSTarget.Cells(i + ofst - 2, 2).Value
i = k - 1
End If
Next i
End With
End Sub
I have an excel sheet with more than 2000 rows.
I use the below macro to add a blank rows with a change in value of cloumn A1.
Sub AddBlankRows()
'
Dim iRow As Integer
Range("a1").Select
'
iRow = 1
'
Do
'![enter image description here][1]
If Cells(iRow + 1, 1) <> Cells(iRow, 1) Then
Cells(iRow + 1, 1).EntireRow.Insert shift:=xlDown
iRow = iRow + 2
Else
iRow = iRow + 1
End If
'
Loop While Not Cells(iRow, 1).Text = ""
'
End Sub
Is there a way insert the row (same with the above macro) with a fourmula and a predefined formatting?
Below is the sample code.
Sub AddBlankRows()
Dim lastRow As Long
Dim iRow As Long
Dim cursor As Long
cursor = 2
With ThisWorkbook.Sheets("sheet1")
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
If (LCase(Trim(.Cells(i, 1))) <> LCase(Trim(.Cells(i + 1, 1)))) Then
.Cells(i + 1, 1).EntireRow.Insert shift:=xlDown
.Cells(i + 1, 1).EntireRow.Interior.Color = vbYellow
lastRow = lastRow + 1
.Cells(i + 1, 2) = WorksheetFunction.Count(.Range(.Cells(cursor, 2), .Cells(i, 2)))
.Cells(i + 1, 2).NumberFormat = "0"
.Cells(i + 1, 3) = WorksheetFunction.Sum(.Range(.Cells(cursor, 3), .Cells(i, 3)))
.Cells(i + 1, 3).NumberFormat = "0.00"
i = i + 2
cursor = i
End If
Next
.Cells(lastRow + 1, 1).EntireRow.Insert shift:=xlDown
.Cells(lastRow + 1, 1).EntireRow.Interior.Color = vbYellow
.Cells(lastRow + 1, 2) = WorksheetFunction.Count(.Range(.Cells(cursor, 2), .Cells(lastRow, 2)))
.Cells(lastRow + 1, 2).NumberFormat = "0"
.Cells(lastRow + 1, 3) = WorksheetFunction.Sum(.Range(.Cells(cursor, 3), .Cells(lastRow, 3)))
.Cells(lastRow + 1, 3).NumberFormat = "0.00"
End With
End Sub